$Version

ip, ipNo1

ip=IntegerPartitions;

ipNo1@n_:=Select[IntegerPartitions@n,Not@MemberQ[#,1]&]

IntegerPartitionsNo1=ipNo1;

grid

grid@x_:=Grid[x /. 0->"·",Alignment->Right]

fi (frequency inverse)

fi[f_]@x_:=First/@Select[Tally@x,Last@#==f&]

fi[1]@{1,2,3,3}

fi[2]@{1,2,3,3}

unimodalQ

unimodalQ@x_:=Module[{p,a,b},
p=Flatten@Position[x,Max@x];
{a,b}={First@p,Last@p};
And[
Min@Take[x,{a,b}]==Max@x,
Apply[And,Not/@Negative@Differences@Take[x,a]],
Apply[And,Not/@Positive@Differences@Take[x,{b,Length@x}]]
]
]

flip

Flips a square matrix around its main antidiagonal.

flip@x_:=Reverse/@Transpose[Reverse/@x]

Row[{{{1,2,3},{4,5,6},{7,8,9}}//Grid,Spacer[30],flip@{{1,2,3},{4,5,6},{7,8,9}}//Grid}]

a={{1,2,3},{4,5,6},{7,8,9}};b=flip@a

Transpose[{a,b},{3,2,1}]//grid

Transpose[{a,b},{3,1,2}]//grid

sw

This finds the n-th antidiagonal going up from the south-west toward the main diagonal.

sw[x_,n_]:=Table[x[[n-k+1,k]],{k,Floor[(1+n)/2]}]

See antidiagonals/nb for examples.

LowerOnes

LowerOnes@n_:=Table[If[k≥nn,1,0],{k,n},{nn,n}]

LowerOnes@4//grid

EqualityMatrix

EqualityMatrix@x_:=Boole@Outer[SameQ,x,x]

balancedternary, bt

bt@x_:=x. 3^Range[0,-1+Length@x]

bt@{-1}

bt@{1}

bt@{0}

Evil,
Odious,
EvilNumberQ,
OdiousNumberQ,
EvilNumber,
OdiousNumber

Evil[n_]:=Select[Range[n],EvenQ[DigitCount[#,2][[1]]]&]

Odious[n_]:=Select[Range[n],OddQ[DigitCount[#,2][[1]]]&]

EvilNumberQ@x_:=EvenQ[DigitCount[x,2][[1]]]

EvilNumber@n_:=Evil[3n][[n]]

OdiousNumberQ@x_:=OddQ[DigitCount[x,2][[1]]]

OdiousNumber@n_:=Odious[3n][[n]]

Evil@24

Evil[3]

Evil[6]

Evil[12]

EvilNumber/@Range@12

KStepCompositions,
KStepC,
preγC,
γC

KStepCompositions[d_,n_,k_]:=Select[StrictCompositions@n,DifferencesAtMostQ[d]&&KStepPartitionQ[#,k]&]

StrictCompositions@5

Select[StrictCompositions@5,DifferencesAtMostQ[1]]

KStepCompositions[7,5,1]

KStepCompositions[5,2]

KStepC[0,k_]:=1

KStepC[n_,k_]:=KStepC[n,k]=Length@KStepCompositions[n,k]

preγC[d_,r_]:=Table[KStepC[i-1,j-1],{i,r},{j,r}]

γC[d_]@r_:=PadRight@Table[KStepC[i-j,j-1],{i,r},{j,i}]

linearrep, conjlinearrep

linearrep@c_:=Style[Row[Flatten@Riffle[Riffle[ConstantArray["—",#],"·"]&/@c,"|"]],24]

conjlinearrep@c_:=linearrep@c/.{"·"->"|","|"->"·"}

The linear representation of a composition c of n is a sequence of three symbols: dashes, dots, and bars obeying certain rules. The main idea is that a part k is represented by k dashes between two successive bars. Dots play no particular role except in the definition of the conjugate.

GapFreePartitionQ, GapFreePartitions, ThickPartitionQ, ThickPartitions

GapFreePartitionQ@x_:=IntegerPartitionQ@x&&SubsetQ[{-1,0},Union@Differences@x]

GapFreePartitions@n_:=Select[IntegerPartitions@n,GapFreePartitionQ]

ThickPartitionQ@x_:=GapFreePartitionQ@x&&GapFreePartitionQ@ConjugatePartition@x

ThickPartitions@n_:=Select[GapFreePartitions@n,ThickPartitionQ]

GapFreePartitionQ, GapFreePartitions

GapFreePartitionQ@x_:=IntegerPartitionQ@x&&SubsetQ[{-1,0},Union@Differences@x]

GapFreePartitions@n_:=Select[IntegerPartitions@n,GapFreePartitionQ]

CompleteByMax,
CompleteByMaxOdd,
CompleteByMaxEven,
CompleteChiByMax,
χ

Clear@CompleteByMax

CompleteByMax[n_,m_]:=(*CompleteByMax[n,m]=*)Select[StrictCompositions@n,(Max@#==m)&&CompleteQ@#&]

Clear@CompleteByMaxOdd

CompleteByMaxOdd[n_,m_]:=(*CompleteByMaxOdd[n,m]=*)Select[StrictCompositions@n,(Max@#==m)&&OddQ[Length@#]&&CompleteQ@#&]

CompleteByMaxOdd[n_,m_,h_]:=Select[StrictCompositions[n,h],(Max@#==m)&&OddQ[Length@#]&&CompleteQ@#&]

Clear@CompleteByMaxEven

CompleteByMaxEven[n_,m_]:=(*CompleteByMaxEven[n,m]=*)Select[StrictCompositions@n,(Max@#==m)&&EvenQ[Length@#]&&CompleteQ@#&]

CompleteByMaxEven[n_,m_,h_]:=Select[StrictCompositions[n,h],(Max@#==m)&&EvenQ[Length@#]&&CompleteQ@#&]

(*CompleteChiByMax[n_,m_]:=CompleteChiByMax[n,m]=Module[{c},
c=CompleteByMax[n,m];
Length@c-2Length@Select[c,EvenQ@*Length]
]*)

CompleteChiByMax[n_,m_]:=Length@CompleteByMaxOdd[n,m]-Length@CompleteByMaxEven[n,m]

CompleteChiByMax[n_,m_,h_]:=Length@CompleteByMaxOdd[n,m,h]-Length@CompleteByMaxEven[n,m,h]

CompleteChiByMaxh[n_,m_]:=CompleteChiByMax[n,m,Floor[PartitionsP[n]/2]]+CompleteChiByMax[n,m,Floor[PartitionsP[n]/2]-PartitionsP[n]]

CompleteChiByMaxh[n_,m_]:=Module[{a,b,c,d},
a=Floor[PartitionsP[n]/4];
b={Floor[PartitionsP[n]/4]+1,Floor[PartitionsP[n]/2]};
c={Floor[PartitionsP[n]/2]+1,Floor[3PartitionsP[n]/4]};
d={Floor[3PartitionsP[n]/4]+1,PartitionsP[n]};
CompleteChiByMax[n,m,a]+CompleteChiByMax[n,m,b]+CompleteChiByMax[n,m,c]+CompleteChiByMax[n,m,d]
]

CompleteChiByMaxh[n_,m_]:=Module[{a,b,c,d,e,f,g,h},
a=Floor[1 PartitionsP[n]/8];
b={Floor[1 PartitionsP[n]/8]+1,Floor[2PartitionsP[n]/8]};
c={Floor[2PartitionsP[n]/8]+1,Floor[3PartitionsP[n]/8]};
d={Floor[3PartitionsP[n]/8]+1,Floor[4PartitionsP[n]/8]};
e={Floor[4PartitionsP[n]/8]+1,Floor[5PartitionsP[n]/8]};
f={Floor[5PartitionsP[n]/8]+1,Floor[6PartitionsP[n]/8]};
g={Floor[6PartitionsP[n]/8]+1,Floor[7PartitionsP[n]/8]};
h={Floor[7PartitionsP[n]/8]+1,Floor[8PartitionsP[n]/8]};
CompleteChiByMax[n,m,a]+CompleteChiByMax[n,m,b]+CompleteChiByMax[n,m,c]+CompleteChiByMax[n,m,d]+CompleteChiByMax[n,m,e]+CompleteChiByMax[n,m,f]+CompleteChiByMax[n,m,g]+CompleteChiByMax[n,m,h]
]

CompleteChiByMaxh[n_,m_]:=Module[{a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15,a16,a17,a18,a19,a20,a21,a22,a23,a24,a25,a26,a27,a28,a29,a30,a31,a32,s},
a1=Floor[1 PartitionsP[n]/32];
a2={Floor[1 PartitionsP[n]/32]+1,Floor[2PartitionsP[n]/32]};
a3={Floor[2PartitionsP[n]/32]+1,Floor[3PartitionsP[n]/32]};
a4={Floor[3PartitionsP[n]/32]+1,Floor[4PartitionsP[n]/32]};
a5={Floor[4PartitionsP[n]/32]+1,Floor[5PartitionsP[n]/32]};
a6={Floor[5PartitionsP[n]/32]+1,Floor[6PartitionsP[n]/32]};
a7={Floor[6PartitionsP[n]/32]+1,Floor[7PartitionsP[n]/32]};
a8={Floor[7PartitionsP[n]/32]+1,Floor[8PartitionsP[n]/32]};
a9={Floor[8PartitionsP[n]/32]+1,Floor[9PartitionsP[n]/32]};
a10={Floor[9PartitionsP[n]/32]+1,Floor[10PartitionsP[n]/32]};
a11={Floor[10PartitionsP[n]/32]+1,Floor[11PartitionsP[n]/32]};
a12={Floor[11PartitionsP[n]/32]+1,Floor[12PartitionsP[n]/32]};
a13={Floor[12PartitionsP[n]/32]+1,Floor[13PartitionsP[n]/32]};
a14={Floor[13PartitionsP[n]/32]+1,Floor[14PartitionsP[n]/32]};
a15={Floor[14PartitionsP[n]/32]+1,Floor[15PartitionsP[n]/32]};
a16={Floor[15PartitionsP[n]/32]+1,Floor[16PartitionsP[n]/32]};
a17={Floor[16PartitionsP[n]/32]+1,Floor[17PartitionsP[n]/32]};
a18={Floor[17PartitionsP[n]/32]+1,Floor[18PartitionsP[n]/32]};
a19={Floor[18PartitionsP[n]/32]+1,Floor[19PartitionsP[n]/32]};
a20={Floor[19 PartitionsP[n]/32]+1,Floor[20PartitionsP[n]/32]};
a21={Floor[20 PartitionsP[n]/32]+1,Floor[21PartitionsP[n]/32]};
a22={Floor[21 PartitionsP[n]/32]+1,Floor[22PartitionsP[n]/32]};
a23={Floor[22PartitionsP[n]/32]+1,Floor[23PartitionsP[n]/32]};
a24={Floor[23PartitionsP[n]/32]+1,Floor[24PartitionsP[n]/32]};
a25={Floor[24PartitionsP[n]/32]+1,Floor[25PartitionsP[n]/32]};
a26={Floor[25PartitionsP[n]/32]+1,Floor[26PartitionsP[n]/32]};
a27={Floor[26PartitionsP[n]/32]+1,Floor[27PartitionsP[n]/32]};
a28={Floor[27PartitionsP[n]/32]+1,Floor[28PartitionsP[n]/32]};
a29={Floor[28PartitionsP[n]/32]+1,Floor[29PartitionsP[n]/32]};
a30={Floor[29 PartitionsP[n]/32]+1,Floor[30PartitionsP[n]/32]};
a31={Floor[30 PartitionsP[n]/32]+1,Floor[31PartitionsP[n]/32]};
a32={Floor[31 PartitionsP[n]/32]+1,Floor[32PartitionsP[n]/32]};

Print[s[1]=CompleteChiByMax[n,m,a1]];Print[s[2]=CompleteChiByMax[n,m,a2]];Print[s[3]=CompleteChiByMax[n,m,a3]];Print[s[4]=CompleteChiByMax[n,m,a4]];Print[s[5]=CompleteChiByMax[n,m,a5]];Print[s[6]=CompleteChiByMax[n,m,a6]];Print[s[7]=CompleteChiByMax[n,m,a7]];Print[s[8]=CompleteChiByMax[n,m,a8]];Print[s[9]=CompleteChiByMax[n,m,a9]];Print[s[10]=CompleteChiByMax[n,m,a10]];Print[s[11]=CompleteChiByMax[n,m,a11]];Print[s[12]=CompleteChiByMax[n,m,a12]];Print[s[13]=CompleteChiByMax[n,m,a13]];Print[s[14]=CompleteChiByMax[n,m,a14]];Print[s[15]=CompleteChiByMax[n,m,a15]];Print[s[16]=CompleteChiByMax[n,m,a16]];
Print[s[17]=CompleteChiByMax[n,m,a17]];Print[s[18]=CompleteChiByMax[n,m,a18]];Print[s[19]=CompleteChiByMax[n,m,a19]];
Print[s[20]=CompleteChiByMax[n,m,a20]];
Print[s[21]=CompleteChiByMax[n,m,a21]];Print[s[22]=CompleteChiByMax[n,m,a22]];Print[s[23]=CompleteChiByMax[n,m,a23]];Print[s[24]=CompleteChiByMax[n,m,a24]];Print[s[25]=CompleteChiByMax[n,m,a25]];Print[s[26]=CompleteChiByMax[n,m,a26]];Print[s[27]=CompleteChiByMax[n,m,a27]];Print[s[28]=CompleteChiByMax[n,m,a28]];Print[s[29]=CompleteChiByMax[n,m,a29]];
Print[s[30]=CompleteChiByMax[n,m,a30]];
Print[s[31]=CompleteChiByMax[n,m,a31]];
Print[s[32]=CompleteChiByMax[n,m,a32]];

s[1]+s[2]+s[3]+s[4]+s[5]+s[6]+s[7]+s[8]+s[9]+s[10]+s[11]+s[12]+s[13]+s[14]+s[15]+s[16]+s[17]+s[18]+s[19]+s[20]+s[21]+s[22]+s[23]+s[24]+s[25]+s[26]+s[27]+s[28]+s[29]+s[30]+s[31]+s[32]+t[1]+t[2]+t[3]+t[4]+t[5]+t[6]+t[7]+t[8]+t[9]+t[10]+t[11]+t[12]+t[13]+t[14]+t[15]+t[16]+t[17]+t[18]+t[19]+t[20]+t[21]+t[22]+t[23]+t[24]+t[25]+t[26]+t[27]+t[28]+t[29]+t[30]+t[31]+t[32]
]

CompleteChiByMaxh[n_,m_]:=Module[{a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15,a16,a17,a18,a19,a20,a21,a22,a23,a24,a25,a26,a27,a28,a29,a30,a31,a32,s},
a1=Floor[1 PartitionsP[n]/64];
a2={Floor[1 PartitionsP[n]/64]+1,Floor[2PartitionsP[n]/64]};
a3={Floor[2PartitionsP[n]/64]+1,Floor[3PartitionsP[n]/64]};
a4={Floor[3PartitionsP[n]/64]+1,Floor[4PartitionsP[n]/64]};
a5={Floor[4PartitionsP[n]/64]+1,Floor[5PartitionsP[n]/64]};
a6={Floor[5PartitionsP[n]/64]+1,Floor[6PartitionsP[n]/64]};
a7={Floor[6PartitionsP[n]/64]+1,Floor[7PartitionsP[n]/64]};
a8={Floor[7PartitionsP[n]/64]+1,Floor[8PartitionsP[n]/64]};
a9={Floor[8PartitionsP[n]/64]+1,Floor[9PartitionsP[n]/64]};
a10={Floor[9PartitionsP[n]/64]+1,Floor[10PartitionsP[n]/64]};
a11={Floor[10PartitionsP[n]/64]+1,Floor[11PartitionsP[n]/64]};
a12={Floor[11PartitionsP[n]/64]+1,Floor[12PartitionsP[n]/64]};
a13={Floor[12PartitionsP[n]/64]+1,Floor[13PartitionsP[n]/64]};
a14={Floor[13PartitionsP[n]/64]+1,Floor[14PartitionsP[n]/64]};
a15={Floor[14PartitionsP[n]/64]+1,Floor[15PartitionsP[n]/64]};
a16={Floor[15PartitionsP[n]/64]+1,Floor[16PartitionsP[n]/64]};
a17={Floor[16PartitionsP[n]/64]+1,Floor[17PartitionsP[n]/64]};
a18={Floor[17PartitionsP[n]/64]+1,Floor[18PartitionsP[n]/64]};
a19={Floor[18PartitionsP[n]/64]+1,Floor[19PartitionsP[n]/64]};
a20={Floor[19 PartitionsP[n]/64]+1,Floor[20PartitionsP[n]/64]};
a21={Floor[20 PartitionsP[n]/64]+1,Floor[21PartitionsP[n]/64]};
a22={Floor[21 PartitionsP[n]/64]+1,Floor[22PartitionsP[n]/64]};
a23={Floor[22PartitionsP[n]/64]+1,Floor[23PartitionsP[n]/64]};
a24={Floor[23PartitionsP[n]/64]+1,Floor[24PartitionsP[n]/64]};
a25={Floor[24PartitionsP[n]/64]+1,Floor[25PartitionsP[n]/64]};
a26={Floor[25PartitionsP[n]/64]+1,Floor[26PartitionsP[n]/64]};
a27={Floor[26PartitionsP[n]/64]+1,Floor[27PartitionsP[n]/64]};
a28={Floor[27PartitionsP[n]/64]+1,Floor[28PartitionsP[n]/64]};
a29={Floor[28PartitionsP[n]/64]+1,Floor[29PartitionsP[n]/64]};
a30={Floor[29 PartitionsP[n]/64]+1,Floor[30PartitionsP[n]/64]};
a31={Floor[30 PartitionsP[n]/64]+1,Floor[31PartitionsP[n]/64]};
a32={Floor[31 PartitionsP[n]/64]+1,Floor[32PartitionsP[n]/64]};
b1={Floor[33 PartitionsP[n]/64]+1,Floor[34 PartitionsP[n]/64]};
b2={Floor[34 PartitionsP[n]/64]+1,Floor[35PartitionsP[n]/64]};
b3={Floor[35PartitionsP[n]/64]+1,Floor[35PartitionsP[n]/64]};
b4={Floor[36PartitionsP[n]/64]+1,Floor[36PartitionsP[n]/64]};
b5={Floor[37PartitionsP[n]/64]+1,Floor[37PartitionsP[n]/64]};
b6={Floor[38PartitionsP[n]/64]+1,Floor[38PartitionsP[n]/64]};
b7={Floor[39PartitionsP[n]/64]+1,Floor[39PartitionsP[n]/64]};
b8={Floor[40PartitionsP[n]/64]+1,Floor[40PartitionsP[n]/64]};
b9={Floor[41PartitionsP[n]/64]+1,Floor[41PartitionsP[n]/64]};
b10={Floor[42PartitionsP[n]/64]+1,Floor[42PartitionsP[n]/64]};
b11={Floor[43PartitionsP[n]/64]+1,Floor[43PartitionsP[n]/64]};
b12={Floor[44PartitionsP[n]/64]+1,Floor[44PartitionsP[n]/64]};
b13={Floor[45PartitionsP[n]/64]+1,Floor[45PartitionsP[n]/64]};
b14={Floor[46PartitionsP[n]/64]+1,Floor[46PartitionsP[n]/64]};
b15={Floor[46PartitionsP[n]/64]+1,Floor[47PartitionsP[n]/64]};
b16={Floor[47PartitionsP[n]/64]+1,Floor[48PartitionsP[n]/64]};
b17={Floor[48PartitionsP[n]/64]+1,Floor[49PartitionsP[n]/64]};
b18={Floor[49PartitionsP[n]/64]+1,Floor[50PartitionsP[n]/64]};
b19={Floor[50PartitionsP[n]/64]+1,Floor[51PartitionsP[n]/64]};
b20={Floor[51 PartitionsP[n]/64]+1,Floor[52PartitionsP[n]/64]};
b21={Floor[52 PartitionsP[n]/64]+1,Floor[53PartitionsP[n]/64]};
b22={Floor[53 PartitionsP[n]/64]+1,Floor[54PartitionsP[n]/64]};
b23={Floor[54PartitionsP[n]/64]+1,Floor[55PartitionsP[n]/64]};
b24={Floor[55PartitionsP[n]/64]+1,Floor[56PartitionsP[n]/64]};
b25={Floor[56PartitionsP[n]/64]+1,Floor[57PartitionsP[n]/64]};
b26={Floor[57PartitionsP[n]/64]+1,Floor[58PartitionsP[n]/64]};
b27={Floor[58PartitionsP[n]/64]+1,Floor[59PartitionsP[n]/64]};
b28={Floor[59PartitionsP[n]/64]+1,Floor[60PartitionsP[n]/64]};
b29={Floor[60PartitionsP[n]/64]+1,Floor[61PartitionsP[n]/64]};
b30={Floor[61 PartitionsP[n]/64]+1,Floor[62PartitionsP[n]/64]};
b31={Floor[62 PartitionsP[n]/64]+1,Floor[63PartitionsP[n]/64]};
b32={Floor[63 PartitionsP[n]/64]+1,Floor[64PartitionsP[n]/64]};



Print[s[1]=CompleteChiByMax[n,m,a1]];Print[s[2]=CompleteChiByMax[n,m,a2]];Print[s[3]=CompleteChiByMax[n,m,a3]];Print[s[4]=CompleteChiByMax[n,m,a4]];Print[s[5]=CompleteChiByMax[n,m,a5]];Print[s[6]=CompleteChiByMax[n,m,a6]];Print[s[7]=CompleteChiByMax[n,m,a7]];Print[s[8]=CompleteChiByMax[n,m,a8]];Print[s[9]=CompleteChiByMax[n,m,a9]];Print[s[10]=CompleteChiByMax[n,m,a10]];Print[s[11]=CompleteChiByMax[n,m,a11]];Print[s[12]=CompleteChiByMax[n,m,a12]];Print[s[13]=CompleteChiByMax[n,m,a13]];Print[s[14]=CompleteChiByMax[n,m,a14]];Print[s[15]=CompleteChiByMax[n,m,a15]];Print[s[16]=CompleteChiByMax[n,m,a16]];
Print[s[17]=CompleteChiByMax[n,m,a17]];Print[s[18]=CompleteChiByMax[n,m,a18]];Print[s[19]=CompleteChiByMax[n,m,a19]];
Print[s[20]=CompleteChiByMax[n,m,a20]];
Print[s[21]=CompleteChiByMax[n,m,a21]];Print[s[22]=CompleteChiByMax[n,m,a22]];Print[s[23]=CompleteChiByMax[n,m,a23]];Print[s[24]=CompleteChiByMax[n,m,a24]];Print[s[25]=CompleteChiByMax[n,m,a25]];Print[s[26]=CompleteChiByMax[n,m,a26]];Print[s[27]=CompleteChiByMax[n,m,a27]];Print[s[28]=CompleteChiByMax[n,m,a28]];Print[s[29]=CompleteChiByMax[n,m,a29]];
Print[s[30]=CompleteChiByMax[n,m,a30]];
Print[s[31]=CompleteChiByMax[n,m,a31]];
Print[s[32]=CompleteChiByMax[n,m,a32]];Print[t[1]=CompleteChiByMax[n,m,b1]];Print[t[2]=CompleteChiByMax[n,m,b2]];Print[t[3]=CompleteChiByMax[n,m,b3]];Print[t[4]=CompleteChiByMax[n,m,b4]];Print[t[5]=CompleteChiByMax[n,m,b5]];Print[t[6]=CompleteChiByMax[n,m,b6]];Print[t[7]=CompleteChiByMax[n,m,b7]];Print[t[8]=CompleteChiByMax[n,m,b8]];Print[t[9]=CompleteChiByMax[n,m,b9]];Print[t[10]=CompleteChiByMax[n,m,b10]];Print[t[11]=CompleteChiByMax[n,m,b11]];Print[t[12]=CompleteChiByMax[n,m,b12]];Print[t[13]=CompleteChiByMax[n,m,b13]];Print[t[14]=CompleteChiByMax[n,m,b14]];Print[t[15]=CompleteChiByMax[n,m,b15]];Print[t[16]=CompleteChiByMax[n,m,b16]];
Print[t[17]=CompleteChiByMax[n,m,b17]];Print[t[18]=CompleteChiByMax[n,m,b18]];Print[t[19]=CompleteChiByMax[n,m,b19]];
Print[t[20]=CompleteChiByMax[n,m,b20]];
Print[t[21]=CompleteChiByMax[n,m,b21]];Print[t[22]=CompleteChiByMax[n,m,b22]];Print[t[23]=CompleteChiByMax[n,m,b23]];Print[t[24]=CompleteChiByMax[n,m,b24]];Print[t[25]=CompleteChiByMax[n,m,b25]];Print[t[26]=CompleteChiByMax[n,m,b26]];Print[t[27]=CompleteChiByMax[n,m,b27]];Print[t[28]=CompleteChiByMax[n,m,b28]];Print[t[29]=CompleteChiByMax[n,m,b29]];
Print[t[30]=CompleteChiByMax[n,m,b30]];
Print[t[31]=CompleteChiByMax[n,m,b31]];
Print[t[32]=CompleteChiByMax[n,m,b32]];

s[1]+s[2]+s[3]+s[4]+s[5]+s[6]+s[7]+s[8]+s[9]+s[10]+s[11]+s[12]+s[13]+s[14]+s[15]+s[16]+s[17]+s[18]+s[19]+s[20]+s[21]+s[22]+s[23]+s[24]+s[25]+s[26]+s[27]+s[28]+s[29]+s[30]+s[31]+s[32]+t[1]+t[2]+t[3]+t[4]+t[5]+t[6]+t[7]+t[8]+t[9]+t[10]+t[11]+t[12]+t[13]+t[14]+t[15]+t[16]+t[17]+t[18]+t[19]+t[20]+t[21]+t[22]+t[23]+t[24]+t[25]+t[26]+t[27]+t[28]+t[29]+t[30]+t[31]+t[32]
]

With[{n=5,m=PartitionsP@5},Join[ip[n,Floor[m/2]],ip[n,Floor[m/2]-m ]]]

χ@M_:=PadRight@Table[CompleteChiByMax[i,j],{i,M},{j,i}]

checkerboard

checkerboard@n_:=Table[(-1)^(k+m)Boole[m≤k],{k,n},{m,n}]

checkerboard@5//Grid

totals

totals@s_:=Column@{
{
"\nTotal/@s,
Total/@Abs@s,
AntidiagonalTotals@s,
AntidiagonalTotals@Abs@s,
Total/@(checkerboard@First@Dimensions@s s),
Total/@(checkerboard@First@Dimensions@s Abs@s)"
},
{
Total/@s,
Total/@Abs@s,
AntidiagonalTotals@s,
AntidiagonalTotals@Abs@s,
Total/@(checkerboard@First@Dimensions@s s),
Total/@(checkerboard@First@Dimensions@s Abs@s)
}
}

DifferencesAtMostQ[d]
gapxxxQ, gapxxx1Q

DifferencesAtMostQ[d] tests whether a composition of n satisfies (Subscript[λ, j])-(Subscript[λ, j-1])≤d.

DifferencesAtMostQ[d_]@x_:=Apply[And,#1≤d&/@Differences[x]]

gap at least 0

Compositions with gaps at least 0 are ordinary unrestricted partitions.

gap0Q@x_:=DifferencesAtMostQ[0][x]

Select[IntegerPartitions@5,gap0Q]

Table[Length@Select[ip@n,gap0Q],{n,24}]

↕ By construction, 
A000041 		a(n) is the number of partitions of n (the partition numbers).
	1, 1, 2, 3, 5, 7, 11, 15, 22, 30, 42, 56, 77, 101, 135, 176, 231, 297, 385, 490, 627, 792, 1002, 1255, 1575,

gaps at least 1

This was our original problem.

gap1Q@x_:=DifferencesAtMostQ[-1][x]

Select[IntegerPartitions@10,gap1Q]

Table[Length@Select[ip@n,gap1Q],{n,24}]

↕ By construction and as expected, 
A000009 		Expansion of Product_{m >= 1} (1 + x^m); number of partitions of n into distinct parts; number of partitions of n into odd parts.
(Formerly M0281 N0100) 		+30
876
	1, 1, 1, 2, 2, 3, 4, 5, 6, 8, 10, 12, 15, 18, 22, 27, 32, 38, 46, 54, 64, 76, 89, 104, 122,

gaps at least 2

gap2Q@x_:=DifferencesAtMostQ[-2][x]

Select[StrictCompositions@12,DifferencesAtMostQ[-2]]

Table[Length@Select[ip@n,DifferencesAtMostQ[-2]],{n,24}]

↕ By construction, 
A003114 		Number of partitions of n into parts 5k+1 or 5k+4.
(Formerly M0266) 		+30
121
	1, 1, 1, 1, 2, 2, 3, 3, 4, 5, 6, 7, 9, 10, 12, 14, 17, 19, 23, 26, 31, 35, 41, 46, 54,

gaps at least 3

gap3Q@x_:=DifferencesAtMostQ[-3][x]

Select[IntegerPartitions@20,gap3Q]

Table[Length@Select[ip@n,gap3Q],{n,24}]

↕ By construction, 
A025157 		Number of partitions of n with distinct parts p(i) such that if i != j, then |p(i) - p(j)| >= 3. 		+30
16
	1, 1, 1, 1, 1, 2, 2, 3, 3, 4, 4, 5, 6, 7, 8, 10, 11, 13, 15, 17, 19, 22, 25, 28, 32,

gaps at least 4

gap4Q@x_:=DifferencesAtMostQ[-4][x]

Select[IntegerPartitions@20,gap4Q]

Table[Length@Select[ip@n,gap4Q],{n,30}]

↕ By construction, 
A025158 		Number of partitions of n with distinct parts p(i) such that if i != j, then |p(i) - p(j)| >= 4. 		+30
3
	1, 1, 1, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 7, 8, 9, 11, 12, 14, 16, 18, 20, 23, 25, 28, 31, 35, 38, 43,

gaps at least 5

gap5Q@x_:=DifferencesAtMostQ[-5][x]

Select[IntegerPartitions@20,gap5Q]

Table[Length@Select[ip@n,gap5Q],{n,30}]

↕ By construction, 
A025159 		Number of partitions of n with distinct parts p(i) such that if i != j, then |p(i) - p(j)| >= 5. 
	1, 1, 1, 1, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 8, 9, 10, 12, 13, 15, 17, 19, 21, 24, 26, 29, 32,

gap at least 0, no 1s

gap01Q@x_:=DifferencesAtMostQ[0][x]&&Not@MemberQ[x,1]

Select[IntegerPartitions@10,gap01Q]

Table[Length@Select[ip@n,gap01Q],{n,24}]

↕ By construction and as expected, 
A002865 		Number of partitions of n that do not contain 1 as a part.
	1, 0, 1, 1, 2, 2, 4, 4, 7, 8, 12, 14, 21, 24, 34, 41, 55, 66, 88, 105, 137, 165, 210, 253, 320

gap at least 1, no 1s

Close to our original problem.

gap11Q@x_:=DifferencesAtMostQ[-1][x]&&Not@MemberQ[x,1]

Select[IntegerPartitions@10,gap11Q]

Table[Length@Select[ip@n,gap11Q],{n,24}]

↕ By construction and as expected, 
A025147 		Number of partitions of n into distinct parts >= 2. 
	1, 0, 1, 1, 1, 2, 2, 3, 3, 5, 5, 7, 8, 10, 12, 15, 17, 21, 25, 29, 35, 41, 48, 56, 66,

gap at least 2, no 1s

gap21Q@x_:=DifferencesAtMostQ[-2][x]&&Not@MemberQ[x,1]

Table[Length@Select[ip@n,gap21Q],{n,18}]

Table[Length@Select[StrictCompositions@n,gap21Q],{n,18}]

↕ By construction and as expected, 
A003106 		Number of partitions of n into parts 5k+2 or 5k+3.
	1, 0, 1, 1, 1, 1, 2, 2, 3, 3, 4, 4, 6, 6, 8, 9, 11, 12, 15,

gap at least 3, no 1s

gap31Q@x_:=DifferencesAtMostQ[-3][x]&&Not@MemberQ[x,1]

Select[IntegerPartitions@20,gap31Q]

Table[Length@Select[StrictCompositions@n,gap31Q],{n,16}]

Table[Length@Select[ip@n,gap31Q],{n,30}]

↕ By construction, 
A237979 		Number of strict partitions of n such that (least part) > number of parts. 		+30
3
	0, 1, 1, 1, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 7, 7, 9, 10, 12, 13, 16, 17, 20, 22, 25, 28, 32, 35, 40, 45, 50, 56, 63, 70, 78, 87, 96, 107, 118, 131, 144, 160, 175, 194, 213, 235, 257, 284, 310, 342, 373, 410, 447, 491, 534, 585, 637, 696, 756, 826, 896, 977, 1060, 1153, 1250, 1359, 1471, 1597, 1729, 1874, 2026, 2195, 2371, 2565 
...
Also the number of partitions into distinct parts with minimal part >= 2 and difference between parts >= 3. [Joerg Arndt, Mar 31 2014]

gap at least 4, no 1s

gap41Q@x_:=DifferencesAtMostQ[-4][x]&&Not@MemberQ[x,1]

Select[IntegerPartitions@20,gap41Q]

Table[Length@Select[ip@n,gap41Q],{n,36}]

↑ Not in OEIS.

gap at least 5, no 1s

gap51Q@x_:=DifferencesAtMostQ[-5][x]&&Not@MemberQ[x,1]

shiftrows, shiftcolumns

shiftrows@x_:=Table[Join[ConstantArray[0,k-1],x[[k]] ],{k,Length@x}]

shiftcolumns@x_:=Transpose@PadRight@shiftrows@Transpose@x

flatten

flatten@x_:=Flatten[StripLastZeros/@x]

sb polynomial

sb[0,x_]:=0

sb[1,x_]:=1

sb[n_,x_]:=sb[n/2,x^2]/;EvenQ[n]

sb[n_,x_]:=x sb[1/2(n-1),x^2]+sb[1/2(n+1),x^2]/;OddQ[n]

tri, diag

tri[f_,n_,x_]:=x^(n-Exponent[f[n,1/x],x])f[n,1/x]

diag[m_,x_]:=x^(-1+Range@Length@m-(Exponent[#,x]&/@m))m

tm

tm[n_,x_]:=If[n==0,0,If[EvenQ@n,tm[n/2,x^2],x-tm[(n-1)/2,x^2]]]

tm[#,1]&/@Range@17

ThueMorse@Range@17

sf polynomial

sf[0,x_]:=0

sf[1,x_]:=1

sf[n_,x_]:=sf[n/2,x^2]/;EvenQ[n]

sf[n_,x_]:=x sf[n-1,x]+sf[n-2,x]/;OddQ[n]

A145865

A145865 		a(0) = 0, a(1) = 1, a(2n) = a(n), a(2n+1) = a(n) - a(n+1). 		1
	0, 1, 1, 0, 1, 1, 0, -1, 1, 0, 1, 1, 0,

A145865@0=0;

A145865@1=1;

A145865@n_:=A145865[n/2]/;EvenQ@n

A145865@n_:=A145865[(n-1)/2]-A145865[(n-1)/2+1]/;OddQ@n

A145865/@Range[0,12]

bow polynomials

bow1[1,x_]:=1

bow1[2,x_]:=0

bow1[n_,x_]:=x bow1[n/2,x^2]+bow1[n/2+1,x^2]/;EvenQ[n]

bow1[n_,x_]:=x bow1[1/2(n-1),x^2]/;OddQ[n]

bow2[1,x_]:=0

bow2[2,x_]:=1

bow2[n_,x_]:=x bow2[n/2,x^2]+bow2[n/2+1,x^2]/;EvenQ[n]

bow2[n_,x_]:=x bow2[1/2(n-1),x^2]/;OddQ[n]

bow[n_,x_]:=bow1[n,x]+bow2[n,x]

On Properties of the General Bow Sequence
Melissa Dennison

A281185 		a(0)=0, a(1)=1, a(2)=0; thereafter, a(2n)=a(n)+a(n+1) for n >= 2, a(2n+1)=a(n) for n >= 1.
	0, 1, 0, 1, 1, 0, 2, 1, 1, 1, 2, 0, 3, 2, 2, 1, 2, 1, 3, 1, 2, 2, 3, 0, 5, 3, 4, 2, 3, 2, 3, 1, 3, 2, 4, 1, 4, 3, 3, 1, 4, 2, 5, 2, 3, 3, 5, 0, 8, 5, 7, 3, 6, 4, 5, 2, 5, 3, 5, 2, 4, 3, 4, 1, 5, 3, 6, 2, 5, 4, 5, 1, 7, 4, 6, 3, 4, 3, 5, 1, 6, 4, 7, 2, 7, 5, 5, 2, 6, 3, 8, 3, 5, 5, 8, 0, 13, 8, 12, 5  	
A “bow” sequence. The bow sequences are a family of recursive sequences defined to have the flipped recursion from the Stern sequence A002487 (called bow for the opposite end of the boat from the stern).  The bow sequences require two initial conditions: a(1)=alpha, a(2)=beta. We also define a(0)=0, although it does not enter into the recursion.

The bow sequences then follow the recursion a(2n)=a(n)+a(n+1) for n at least 2, and a(2n+1)=a(n).  This particular bow sequence has initial conditions a(1)=0, a(2)=1 and (along with the sequence A106345 with initial conditions a(1)=1, a(2)=0) is of particular importance when studying the general bow sequences.

A106345 		Diagonal sums of number triangle A106344. 
	1, 0, 1, 1, 1, 0, 2, 1, 2, 1, 1, 1, 2, 0, 3, 2, 3, 1, 3, 2, 2, 1, 2, 1, 3, 1, 2, 2, 3, 0, 5, 3, 5, 2, 4, 3, 4, 1, 5, 3, 4, 2, 3, 2, 3, 1, 3, 2, 4, 1, 4, 3, 3, 1, 4, 2, 5, 2, 3, 3, 5, 0, 8, 5, 8, 3, 7, 5, 6, 2, 7, 4, 7, 3, 5, 4, 6, 1, 8, 5, 7, 3, 6, 4, 5, 2, 5, 3, 5, 2, 4, 3, 4, 1, 5, 3, 6, 2, 5, 4, 5, 1, 7 

This is a “bow” sequence, a companion to A281185. - N. J. A. Sloane, Apr 26 2017

triangular

triangular@nn_:=Table[1/2n(n+1),{n,nn}]

triangular@5

aerate, duplicate

aerate@x_:=Riffle[x,0]

aerate@Range@11

aerate@Range@12

duplicate@x_:=Flatten@Transpose@{x,x}

duplicate@Range@12

op (overpartitions),
ipno1 (integer partitions without a 1),
opno1 (overpartitions without a 1)

op@n_:=Flatten[Table[Flatten[Outer[List,head@@DistinctPartitions@k,head@@ip[n-k]],1],{k,0,n}]/.head->List,1]

ipno1@n_:=Select[ip@n,Not@MemberQ[#,1]&]

opno1@n_:=Flatten[Table[Flatten[Outer[List,head@@DistinctPartitionsNo1@k,head@@ipno1[n-k]],1],{k,0,n}]/.head->List,1]

OverPartitionsByMax[n_,m_]:=Select[op@n,Max@#==m&]

reciprocal

reciprocal[poly_,x_]:=x^Exponent[poly,x](poly/.x->1/x)

DiagonalSums, AntidiagonalTotals, ColumnSums

DiagonalSums@mat_:=Reverse@AntidiagonalSums@Transpose@Reverse@mat

DiagonalSums@{{1,2,3},{4,5,6},{7,8,9}}

AntidiagonalTotals@mat_:=Total/@Take[
Transpose@MapIndexed[
RotateRight[#1,#2-1]&,
Join[#,Table[0,Length@mat]]&/@mat],
Length@mat
]

AntidiagonalSums=AntidiagonalTotals;

ColumnSums@x_:=Total/@Transpose@x

Zeckendorf Representation

LeadingIndex[n_Integer?(#≥0&)]:=Module[
{k},
If[n==0,k=2,For[k=2,Fibonacci[k]≤n,k++];k--;];k]

ZeckendorfRepresentation[n_Integer?(#≥0&)]:=Module[
{i,k,l,m,addon,r},
k=0;
If[n==0,
r={0},
If[n==1,
r={1},
l=LeadingIndex[n];m=n-Fibonacci[l];k=LeadingIndex[m];addon=Flatten[{1,Table[0,{i,k+2,l}]}];r=Flatten[{addon,ZeckendorfRepresentation[m]}]]
];r]

DistinctSubsumPartitions

DistinctSubsumPartitions@n_:=Module[{x},Select[ip@n,SubsetQ[{0,1},Union@CoefficientList[sp[#,x],x]]&]]

FibbinaryMatrix

FibbinaryMatrixAux[n_Integer]:=Block[{k=Ceiling[Log[GoldenRatio,n*Sqrt[5]]],t=n,fr={}},While[k>1,If[t≥Fibonacci[k],AppendTo[fr,1];t=t-Fibonacci[k],AppendTo[fr,0]];k--];Reverse@fr]

FibbinaryMatrix@n_:=PadRight[FibbinaryMatrixAux/@Range@n]

LP, LLP, LLPA

LP@x_:=ListPlot@x

LLP@x_:=ListLinePlot@x

LLPA@x_:=ListLinePlot[x,PlotRange->All]

FibbinaryArray

FibbinaryArray[n_Integer]:=Block[{k=Ceiling[Log[GoldenRatio,n*Sqrt[5]]],t=n,fr={}},While[k>1,If[t≥Fibonacci[k],AppendTo[fr,1];t=t-Fibonacci[k],AppendTo[fr,0]];k--];Reverse@fr]

semiFibonacci

semiFibonacci=SemiFibonacci;

SemiFibonacci[0]=0;

SemiFibonacci[1]=1;

SemiFibonacci[n_?EvenQ]:=SemiFibonacci@n=SemiFibonacci[n/2]

SemiFibonacci[n_?(OddQ@#&&#>0&)]:=SemiFibonacci@n=SemiFibonacci[n-1]+SemiFibonacci[n-2]

SemiFibonacci[n_?(OddQ@#&&#<0&)]:=SemiFibonacci[n+2]-SemiFibonacci[n+1]

semiLucas

semiLucas[1]=2;semiLucas[2]=1;

semiLucas[n_?EvenQ]:=semiLucas[n/2]

semiLucas[n_?OddQ]:=semiLucas[n-1]+semiLucas[n-2]

semi-Pell

semiPell1[0]=0;

semiPell1[1]=1;

semiPell1@n_:=semiPell1[n/2]/;EvenQ@n

semiPell1@n_:=2semiPell1[n-1]+semiPell1[n-2]/;OddQ@n&&n>1

semiPell2[0]=0;

semiPell2[1]=1;

semiPell2@n_:=semiPell2[n/2]/;EvenQ@n

semiPell2@n_:=semiPell2[n-1]+2semiPell2[n-2]/;OddQ@n&&n>1

HyperbinaryPartitionQ, HyperbinaryPartitions

HyperbinaryPartitionQ@{1,1}=True;

HyperbinaryPartitionQ@{1}=True;

HyperbinaryPartitionQ[x_]:=Count[x,1]≤2&&And@@(EvenQ/@DeleteCases[x,1])&&HyperbinaryPartitionQ[1/2DeleteCases[x,1]]

HyperbinaryPartitions@n_:=Select[IntegerPartitions[n],HyperbinaryPartitionQ]

SternBrocot

SternBrocot[m_] := Module[{a = 1, b = 0, n = m}, While[n > 0, If[OddQ[n], b = a+b, a = a+b]; n = Floor[n/2]]; b];  (* Jean-François Alcover, Sep 06 2013, translated from 2nd Maple program *)

SternBrocot@0

SternBrocot/@Range[0,20]

AntidiagonalTotals

AntidiagonalTotals@matrix_:=Total/@Take[
Transpose@MapIndexed[
RotateRight[#1,#2-1]&,
Join[#,Table[0,Length@matrix]]&/@matrix],
Length@matrix
]

BinaryQ

BinaryQ@x_:=Apply[And,IntegerQ@#&&#≥0&/@Log[2,x]]

Select[IntegerPartitions@12,BinaryQ]

BinaryPartitions@n_:=Select[IntegerPartitions@n,BinaryQ]

BinaryPartitions@12

Totatives

Totatives[n_]:=Select[Range@n,GCD[#,n]==1&]

AllCycles, cycles

AllCycles[c_Cycles,n_Integer]:=
Sort[
Join[
First@c,
List/@Complement[
Range@n,
Union@Flatten@First@c]
],
First@#1<First@#2&]/;n>0

cycles[n_,k_]:=Select[AllCycles[PermutationCycles@#,n]&/@Permutations[Range@n],(Length@#==k)&]

cycles[n_,k_]:=Select[AllCycles[PermutationCycles@#,n]&/@Permutations[Range@n],(Length@#==k)&]

Column@cycles[4,#]&/@Range[4]

KSetPartitions, SetPartitions

SetPartitions[0]:={{}}

SetPartitions[{}]:={{}}

SetPartitions[s_List]:=Flatten[Table[KSetPartitions[s,i],{i,Length[s]}],1]

SetPartitions[n_Integer?Positive]:=SetPartitions[Range[n]]

KSetPartitions[0,0]:={{}}

KSetPartitions[{},0]:={{}}

KSetPartitions[s_List,0]:={}

KSetPartitions[s_List,k_Integer]:={}/;k>Length[s]

KSetPartitions[s_List,k_Integer]:={({#1}&)/@s}/;k===Length[s]

KSetPartitions[s_List,k_Integer]:=Block[{$RecursionLimit=∞,j},Join[(Prepend[#1,{First[s]}]&)/@KSetPartitions[Rest[s],k-1],Flatten[(Table[Prepend[Delete[#1,j],Prepend[#1[[j]],s[[1]]]],{j,Length[#1]}]&)/@KSetPartitions[Rest[s],k],1]]]/;k>0&&k<Length[s]

KSetPartitions[0,k_Integer?Positive]:={}

KSetPartitions[n_Integer?Positive,0]:={}

KSetPartitions[n_Integer?Positive,k_Integer?Positive]:=KSetPartitions[Range[n],k]

StrictCompositions, StrictDistinctCompositions

StrictCompositions[n_]:=StrictCompositions@n=Join@@Permutations/@IntegerPartitions[n]

StrictCompositions[n_,h_]:=Join@@Permutations/@ip[n,h]

StrictDistinctCompositions[n_]:=Join@@Permutations/@DistinctPartitions[n]

StrictCompositions@4

Differences/@%

GapFreeCompositions@n_:=Select[compositions@n,SubsetQ[{-1,0,1},Differences@#]&]

GapFreeCompositions@3

GapFreeCompositions@4

WeakCompositions

WeakCompositions[n_]:=Join@@(Permutations@PadRight[#,n]&/@IntegerPartitions[n])

WeakCompositions@1

WeakCompositions@2

WeakCompositions@3

StrictIntegerCompositions

StrictIntegerCompositions[n_]:=Join@@Permutations/@IntegerPartitions[n]

StrictIntegerCompositions[n_,k_]:=Join@@Permutations/@IntegerPartitions[n,k]

StrictIntegerCompositions[n_,{k_}]:=Join@@Permutations/@IntegerPartitions[n,{k}]

StrictIntegerCompositions[n_,{kmin_,kmax_}]:=Join@@Permutations/@IntegerPartitions[n,{kmin,kmax}]

StrictIntegerCompositions[n_,kspec_,s_List]:=Join@@Permutations/@IntegerPartitions[n,kspec,s]

StrictIntegerCompositions[n_,kspec_,sspec_,m_]:=Join@@Permutations/@IntegerPartitions[nkspec,sspec,m]

StrictCompositionsOdd, StrictCompositionsEven, StrictCompositionsByMaxOdd, StrictCompositionsByMaxEven, StrictCompositionsByMax

StrictCompositionsOdd@n_:=Select[StrictCompositions@n,OddQ@*Length]

StrictCompositionsEven@n_:=Select[StrictCompositions@n,EvenQ@*Length]

StrictCompositionsByMaxOdd[n_,m_]:=StrictCompositionsByMaxOdd[n,m]=Select[StrictCompositions[n],OddQ@Length@#&&Max[#1]==m&]

NumberStrictCompositionsByMaxOdd[n_,m_]:=NumberStrictCompositionsByMaxOdd[n,m]=Length@Select[StrictCompositions[n],OddQ@Length@#&&Max[#1]==m&]

NumberStrictCompositionsByMaxOdd[n_]:=
PadRight@Table[NumberStrictCompositionsByMaxOdd[i,j],{i,n},{j,i}]

StrictCompositionsByMaxEven[n_,m_]:=StrictCompositionsByMaxEven[n,m]=Select[StrictCompositions[n],EvenQ@Length@#&&Max[#1]==m&]

NumberStrictCompositionsByMaxEven[n_,m_]:=NumberStrictCompositionsByMaxEven[n,m]=Length@Select[StrictCompositions[n],EvenQ@Length@#&&Max[#1]==m&]

NumberStrictCompositionsByMaxEven[n_]:=
PadRight@Table[NumberStrictCompositionsByMaxEven[i,j],{i,n},{j,i}]

NumberStrictCompositionsByMax[n_,m_]:=NumberStrictCompositionsByMax[n,m]=Length@StrictCompositionsByMaxOdd[n,m]-Length@StrictCompositionsByMaxEven[n,m]

NumberStrictCompositionsByMax@n_:=PadRight@Table[NumberStrictCompositionsByMax[i,j],{i,n},{j,i}]

NumberStrictCompositionsByMaxSignless[n_,m_]:=NumberStrictCompositionsByMaxSignless[n,m]=Length@Select[StrictCompositions[n],Max[#1]==m&]

NumberStrictCompositionsByMaxSignless@n_:=PadRight@Table[NumberStrictCompositionsByMaxSignless[i,j],{i,n},{j,i}]

StrictDistinctCompositionsOdd, StrictDistinctCompositionsEven, StrictDistinctCompositionsByMaxOdd, StrictDistinctCompositionsByMaxEven, StrictDistinctCompositionsByMax

StrictDistinctCompositionsOdd@n_:=Select[StrictDistinctCompositions@n,OddQ@*Length]

StrictDistinctCompositionsEven@n_:=Select[StrictDistinctCompositions@n,EvenQ@*Length]

StrictDistinctCompositionsByMaxOdd[n_,m_]:=StrictDistinctCompositionsByMaxOdd[n,m]=Select[StrictDistinctCompositions[n],OddQ@Length@#&&Max[#1]==m&]

StrictDistinctCompositionsByMaxEven[n_,m_]:=StrictDistinctCompositionsByMaxEven[n,m]=Select[StrictDistinctCompositions[n],EvenQ@Length@#&&Max[#1]==m&]

StrictDistinctCompositionsByMax[n_,m_]:=StrictDistinctCompositionsByMax[n,m]=Length@StrictDistinctCompositionsByMaxOdd[n,m]-Length@StrictDistinctCompositionsByMaxEven[n,m]

StrictDistinctCompositionsByMax@n_:=PadRight@Table[StrictDistinctCompositionsByMax[i,j],{i,n},{j,i}]

StrictDistinctCompositionsByMaxSignless[n_,m_]:=StrictDistinctCompositionsByMaxSignless[n,m]=Length@Select[StrictDistinctCompositions[n],Max[#1]==m&]

StrictDistinctCompositionsByMaxSignless@n_:=PadRight@Table[StrictDistinctCompositionsByMaxSignless[i,j],{i,n},{j,i}]

WeakCompositionsOdd, WeakCompositionsEven, WeakCompositionsByMaxOdd, WeakCompositionsByMaxEven, WeakCompositionsByMax

WeakCompositionsOdd@n_:=Select[WeakCompositions@n,OddQ@Length@DeleteCases[#,0]&]

WeakCompositionsEven@n_:=Select[WeakCompositions@n,EvenQ@Length@DeleteCases[#,0]&]

WeakCompositionsByMaxOdd[n_,m_]:=WeakCompositionsByMaxOdd[n,m]=Select[WeakCompositions[n],OddQ@Length@DeleteCases[#,0]&&Max[#1]==m&]

WeakCompositionsByMaxEven[n_,m_]:=WeakCompositionsByMaxEven[n,m]=Select[WeakCompositions[n],EvenQ@Length@DeleteCases[#,0]&&Max[#1]==m&]

WeakCompositionsByMax[n_,m_]:=WeakCompositionsByMax[n,m]=Length@WeakCompositionsByMaxOdd[n,m]-Length@WeakCompositionsByMaxEven[n,m]

WeakCompositionsByMax@n_:=PadRight@Table[WeakCompositionsByMax[i,j],{i,n},{j,i}]

CompleteCompositions

CompleteCompositions@n_:=Apply[Join,Permutations/@CompletePartitions@n]

GapFreePartitionQ, GapFreePartitions

ip@8

Differences@{4,4}

Differences/@ip@8

GapFreePartitionQ@x_:=-1≤Min@Differences@x

Select[ip@8,GapFreePartitionQ]

GapFreePartitions@n_:=Select[IntegerPartitions@n,GapFreePartitionQ]

AtLeastGap2PartitionQ,  AtLeastGap2Partitions, AtLeastGap2No1Partitions, AtLeastGap2PartitionsOdd, AtLeastGap2PartitionsEven, PartitionsGap2ByMaxOdd, PartitionsGap2ByMaxEven, PartitionsGap2ByMax,
AtLeastGap3PartitionQ, AtLeastGap3Partitions,
AtLeastGap4PartitionQ, AtLeastGap4Partitions

AtLeastGap2PartitionQ@x_:=Not@MemberQ[Differences@x,0]&&Not@MemberQ[Differences@x,-1]

AtLeastGap2Partitions@n_:=Select[IntegerPartitions@n,AtLeastGap2PartitionQ]

AtLeastGap2No1Partitions@n_:=Select[IntegerPartitions@n,1<Min@# &&AtLeastGap2PartitionQ@#&]

AtLeastGap2PartitionsOdd@n_:=Select[ip@n,AtLeastGap2PartitionQ@#&&OddQ@Length@#&]

AtLeastGap2PartitionsEven@n_:=Select[ip@n,AtLeastGap2PartitionQ@#&&EvenQ@Length@#&]

PartitionsGap2ByMaxOdd[n_,m_]:=PartitionsGap2ByMaxOdd[n,m]=Select[IntegerPartitions[n],OddQ@Length@#&&AtLeastGap2PartitionQ@#&&Max[#1]==m&]

PartitionsGap2ByMaxEven[n_,m_]:=PartitionsGap2ByMaxEven[n,m]=Select[IntegerPartitions[n],EvenQ@Length@#&&AtLeastGap2PartitionQ@#&&Max[#1]==m&]

PartitionsGap2ByMax[n_,m_]:=PartitionsGap2ByMax[n,m]=Length@PartitionsGap2ByMaxOdd[n,m]-Length@PartitionsGap2ByMaxEven[n,m]

PartitionsGap2ByMax@n_:=PadRight@Table[PartitionsGap2ByMax[i,j],{i,n},{j,i}]

AtLeastGap3PartitionQ[x_]:=!MemberQ[Differences[x],0]&&!MemberQ[Differences@x,-1]&&!MemberQ[Differences[x],-2]

AtLeastGap3Partitions[n_]:=Select[IntegerPartitions[n],AtLeastGap3PartitionQ]

AtLeastGap3No1Partitions@n_:=Select[AtLeastGap2No1Partitions@n,1AtLeastGap3PartitionQ]

AtLeastGap4PartitionQ[x_]:=!MemberQ[Differences[x],0]&&!MemberQ[Differences@x,-1]&&!MemberQ[Differences[x],-2]&&!MemberQ[Differences[x],-3]

AtLeastGap4Partitions[n_]:=Select[IntegerPartitions[n],AtLeastGap4PartitionQ]

AtLeastGap4No1Partitions@n_:=Select[AtLeastGap3No1Partitions@n,1AtLeastGap4PartitionQ]

AtLeastGap5PartitionQ[x_]:=!MemberQ[Differences[x],0]&&!MemberQ[Differences@x,-1]&&!MemberQ[Differences[x],-2]&&!MemberQ[Differences[x],-3]&&!MemberQ[Differences[x],-4]

AtLeastGap5Partitions[n_]:=Select[IntegerPartitions[n],AtLeastGap5PartitionQ]

AtLeastGap5No1Partitions@n_:=Select[AtLeastGap4No1Partitions@n,1AtLeastGap5PartitionQ]

psort

Sorts from the left and ignores lengths of lists.

psort@x_:=Reverse[StripZeros/@Sort@PadRight@x]

Row/@(psort@ip@9)

union

The union of two partitions. This keeps multiplicity and sorts down.

union[λ1_,λ2_]:=Reverse@Sort@Join[λ1,λ2]

μ, μodd, μeven, μboth, μ1

μ@n_:=PadRight@Table[PartitionsMuByMax[i,j],{i,3,n+2},{j,3,i}]

μodd@n_:=PadRight@Table[NumberOfOddDistinctPartitionsByMax[i,j],{i,3,n+2},{j,3,i}]

μeven@n_:=PadRight@Table[NumberOfEvenDistinctPartitionsByMax[i,j],{i,3,n+2},{j,3,i}]

μ1@n_:=PadRight@Table[PartitionsMuByMax[i,j],{i,n},{j,i}]

γ, ω, τ

γ@n_:=PadRight@Table[GeneralizedComplete[s-k,k-1],{s,3,n+2},{k,3,s}]

ω@n_:=PadRight@Table[CompleteByOnes[i],{i,n}]

τ@n_:=Table[Boole[i≥j],{i,n},{j,n}]

γ1@n_:=PadRight@Table[GeneralizedComplete[s-k,k-1],{s,n},{k,s}]

CompleteMeasure

CompleteMeasure@x_:=1+PadLeft[Append[Total/@Table[Drop[x,j],{j,Length@x-1}],0]]-x

Checkerboard ch

ch@n_:=Table[(-1)^(i+j)Boole[i≥j],{i,n},{j,n}]

ch@5//grid

Inverse@ch@5//grid

AddPart

AddPart[p_,k_]:=Reverse@Sort@Append[p,k]

AddPart[{5,4,2,2,1,1,1},2]

AddPart[{5,4,2,2,1,1,1},3]

Operations on Multisets

s1={"a","a","a","b","c","c","d"};
s2={"a","a","b","b","c","c","e"};
s3={"a","b","b","c","c","e","e"};

multisetUnion

ClearAll[multisetUnion]
multisetUnion[a___] := 
	With[{counts = Merge[Counts /@ {a}, Max]}, 
		Join @@ KeyValueMap[ConstantArray, counts]
		]

multisetUnion[]

multisetUnion[s1]

multisetUnion[s1,s2]

multisetUnion[s1,s2,s3]

multisetUnionSum

ClearAll[multisetUnionSum]
multisetUnionSum[a___] := 
	With[{counts = Merge[Counts /@ {a}, Total]}, 
		Join @@ KeyValueMap[ConstantArray, counts]
		]

multisetUnionSum[]

multisetUnionSum[s1]

multisetUnionSum[s1,s2]

multisetUnionSum[s1,s2,s3]

multisetIntersection

ClearAll[multisetIntersection]
multisetIntersection[a___] := 
	With[{counts = Merge[KeyIntersection[Counts /@ {a}], Min]}, 
		Join @@ KeyValueMap[ConstantArray, counts]
		]

multisetIntersection[]

multisetIntersection[s1]

multisetIntersection[s1,s2]

multisetIntersection[s1,s2,s3]

multisetComplement

ClearAll[multisetComplement]
multisetComplement[a___] /; 
	Length[{a}] > 0 || Message[multisetComplement::argm, multisetComplement, 0, 1] := 
	Module[{counts}, 
		counts = KeyUnion[Counts /@ {a}] /. Missing["KeyAbsent", _] -> 0; 
		counts = Fold[Merge[{##}, Max[Subtract@@#, 0] &]&, 
			First @ counts, Rest@ counts]; 
		Join @@ KeyValueMap[ConstantArray, counts]
		]

multisetComplement[]

multisetComplement[{}]

multisetComplement[s1]

multisetComplement[s1,s2]

multisetComplement[s1,s2,s3]

multisetSymmetricDifference

s1

s2

multisetSymmetricDifference[a_,b_]:=multisetUnionSum[multisetComplement[a,b],multisetComplement[b,a]]

multisetSymmetricDifference[s1,s2]

d

Clear[d]

d[n_,0]:=0

d[0,k_]:=0

d[n_,1]:=1/;n>0

d[n_,k_]:=d[n-1,k-1]+d[n-k,k]/;k>1&&n≥2k-1

Park’s condition n≥3k-1 is modified to n≥2k-1 and the next case can be dropped, since d[n-k,k] is now zero under its conditions.

(*d[n_,k_]:=d[n-1,k-1]/;k>1&&2k-1≤n≤3k-2*)

d[n_,k_]:=0/;k>1&&3k-1≤n

d[n_,k_]:=0

d[n_]:=Sum[d[n,m],{m,Floor[(n+1)/2]}]

d/@Range[13]

Table[d[n,k],{n,12},{k,7}]//Grid

PartitionsByMax, PartitionsByMaxSigned

(*PartitionsByMax[n_,m_]:=Select[IntegerPartitions@n,(Max@#==m)&]*)

(*PartitionsByMaxSigned[n_,m_]:=PartitionsByMaxSigned[n,m]=Module[{x},
x=PartitionsByMax[n,m];
Length@x-2Length@Select[x,EvenQ@Length@#&]
]*)

(*PartitionsByMaxSigned@k_:=Table[PartitionsByMaxSigned[n,m],{n,k},{m,n}]*)

FullPartitions

FullPartitions@n_:=Select[DistinctPartitions@n,CompletePartitionQ]

AddPartitions

AddPartitions[p_,q_]:=Reverse@Sort@Join[p,q]

AddPartitions[{5,4,2,2,1,1,1},{4,3,2,1,1,1}]

PartitionFrequencies

PartitionFrequencies@p_:=Last/@Sort@Join[Tally@p,{#,0}&/@Complement[Range@Max@p,p]]

ip@5

PartitionFrequencies/@%

tallyaux

tallyaux[list_]:=Module[{x},
x=First/@list;
Last/@Sort@Join[list,{#,0}&/@Complement[Range@Max@x,x]]
]

Tally@{2,1,4,1}

tallyaux@Tally@{2,1,4,1}

SemiFibonacciPartitions

SemiFibonacciPartitions[1]={{1}};

SemiFibonacciPartitions[m_]:=2SemiFibonacciPartitions[m/2]/;EvenQ@m

SemiFibonacciPartitions[m_]:=Union[
Append[#,1]&/@SemiFibonacciPartitions[m-1],
Reverse@Sort@Union[Select[#,EvenQ],2+Select[#,OddQ]]&/@SemiFibonacciPartitions[m-2] 
]/;OddQ@m

Row/@SemiFibonacciPartitions@11

bothodd[{a_,b_}]:=OddQ[(a/(GCD[a,b]))]&&OddQ[(b/(GCD[a,b]))]

JoinToCompletePartitions

JoinToCompletePartitions[n_,p_]:=Reverse@Sort@Join[#,p]&/@CompletePartitions[n]

CompleteQ,
GeneralizedCompletePartitionQ, 
CompletePartitionQ, 
GeneralizedCompletePartitions,
GeneralizedComplete, 
CompletePartitions, 
Complete, 
CompletePartitionsByMax, 
AugmentCompleteByMax, 
AddibleParts, 
ShiftedGeneralizedCompletePartitions, 
ShiftedGeneralizedComplete, 
CompleteByOnes,
CompleteChildren, 
CompletePartitionQ

superseded by KStep family

(Subscript[λ, 1])≤1+(Subscript[λ, 2])+(Subscript[λ, 3])+…+(Subscript[λ, k])=n+1-(Subscript[λ, 1]), so (Subscript[λ, 1])≤((n+1)/2).

(*CompleteQ@x_:=1==Last@x&&Apply[And,Thread@LessEqual[Most@x,1+Reverse@Most@Accumulate@Reverse@x]]*)

(*GeneralizedCompletePartitionQ[λ_,k_]:=MemberQ[Range@k,Last@λ]&&And@@Table[λ[[j]]-k≤Total@Drop[λ,First@Last@Position[λ,λ[[j]]] ],{j,-1+Length@λ}]*)

(*CompletePartitionQ@p_:=GeneralizedCompletePartitionQ[p,1]*)

Let (Subscript[Γ, n,k]) be the set of generalized complete partitions of n with parameter k. Let us use the shorter for k-complete partition of n. (Subscript[Γ, n,k]) is calculated by GeneralizedCompletePartitions[n, k].

(*GeneralizedCompletePartitions[0,_]:={{0}}*)

(* old definition: GeneralizedCompletePartitions[0,_]:={{}} *)

(*GeneralizedCompletePartitions[n_,k_]:=Select[IntegerPartitions@n,GeneralizedCompletePartitionQ[#,k]&]*)

(*Select[IntegerPartitions@7,GeneralizedCompletePartitionQ[#,6]&]*)

Here are two examples.

(*Row/@GeneralizedCompletePartitions[7,1]*)

(*Row/@GeneralizedCompletePartitions[6,2]*)

Let (Subscript[γ, n,k])=# (Subscript[Γ, n,k]); it counts the number of k-complete partitions of n. It is calculated by GeneralizedComplete[n,k].

(*GeneralizedComplete[n_,k_]:=GeneralizedComplete[n,k]=Length@GeneralizedCompletePartitions[n,k]*)

(*GeneralizedComplete@m_:=Table[GeneralizedComplete[n,k],{n,m},{k,n}]*)

Let (Subscript[Χ, n]) be the set of complete partitions of n and let (Subscript[χ, n])=(Subscript[#Χ, n]); the corresponding Mathematica functions are CompletePartitions[n] and Complete[n]. Clearly (Subscript[Χ, n])=(Subscript[Γ, n,1]) and (Subscript[χ, n])=(Subscript[γ, n,1]).

(*CompletePartitions[n_]:=GeneralizedCompletePartitions[n,1]*)

(*Complete[n_]:=GeneralizedComplete[n,1]*)

(*AugmentCompleteByMax[nn_]:=Prepend[
Prepend[
PadRight@Table[CompleteByMax[n,m],{n,nn},{m,(n+1)/2}],
Boole[#≤1]&/@Range[(nn+1)/2]
],
Table[0,(nn+1)/2]
]*)

(*SumToRightOfPart[p_,u_]:=Total[Drop[p,Last@First@Position[p,u]]]/;MemberQ[p,1]*)

(*AddibleParts@p_:=Select[Union@p,SumToRightOfPart[p,#]≥#&]*)

(*ShiftedGeneralizedCompletePartitions[s_,k_]:=GeneralizedCompletePartitions[s-k,k-1]*)

(*ShiftedGeneralizedComplete[s_,k_]:=GeneralizedComplete[s-k,k-1]*)

(*CompleteByOnes@n_:=Module[
{t},
t=Tally[Sort[Count[#,1]&/@CompletePartitions[n]]];Last/@Sort@Join[t,{#,0}&/@Complement[Range@n,First/@t]]
]*)

(*CompleteChildren[p_?CompletePartitionQ]:=Join[List@Append[p,1],p+ReplacePart[0p,1,Position[p,#][[1,1]]]&/@AddibleParts@p]*)

KStepPartitionQ[λ_,k_]:=MemberQ[Range@k,Last@λ]&&And@@Table[λ[[j]]-k≤Total@Drop[λ,First@Last@Position[λ,λ[[j]]] ],{j,-1+Length@λ}]

KStepPartitionQ[0,_]:={{0}}

KStepPartitions[n_,k_]:=Select[IntegerPartitions@n,KStepPartitionQ[#,k]&]

KStep[0,k_]:=1

KStep[n_,k_]:=KStep[n,k]=Length@KStepPartitions[n,k]

CompletePartitionQ@{}=True;

CompletePartitionQ@p_:=KStepPartitionQ[p,1]

CompletePartitions[0]={{}};

CompletePartitions[n_]:=KStepPartitions[n,1]

Complete[n_]:=KStep[n,1]

preγ1@r_:=Table[KStep[i-1,j-1],{i,r},{j,r}]

γ1@r_:=PadRight@Table[KStep[i-j,j-1],{i,r},{j,i}]

MaximumDifferenceKStepPartitionQ[λ_,k_,d_]:=DifferencesAtMostQ[d]@λ&&KStepPartitionQ[λ,k]

MaximumDifferenceKStepPartitionQ[λ_,0,d_]:={{0}}

MaximumDifferenceKStepCompositions[n_,k_,d_]:=Select[StrictCompositions@n,MaximumDifferenceKStepPartitionQ[#,k,d]&]

MaximumDifferenceKStep[0,k_,_]:=1

MaximumDifferenceKStep[n_,k_,d_]:=Length@MaximumDifferenceKStepCompositions[n,k,d]

preγδ1[d_]@r_:=Table[MaximumDifferenceKStep[i-1,j-1,d],{i,r},{j,r}]

γδ1[d_]@r_:=PadRight@Table[MaximumDifferenceKStep[i-j,j-1,d],{i,r},{j,i}]

(*MaximumDifferenceKStepCompositionsno1[n_,k_,d_]:=Select[StrictCompositions@n,Count[#,1]==1&&MaximumDifferenceKStepPartitionQ[#,k,d]&]*)

MaximumDifferenceKStepCompositionsno1[n_,k_,d_]:=Select[StrictCompositions@n,1==Last@#&&Count[#,1]==1&&DifferencesAtMostQ[d]@#&&KStepPartitionQ[#,k]&]

MaximumDifferenceKStepno1[0,k_,_]:=1

MaximumDifferenceKStepno1[n_,k_,d_]:=Length@MaximumDifferenceKStepCompositionsno1[n,k,d]

preγδno1[d_]@r_:=Table[MaximumDifferenceKStepno1[i-1,j-1,d],{i,0,r-1},{j,0,r-1}]

γδno1[d_]@r_:=PadRight@Table[MaximumDifferenceKStepno1[i-j,j-1,d],{i,0,r-1},{j,0,i}]

gaps

0

gap0Q@x_:=DifferencesAtMostQ[0][x]

Gap0ByMax[n_,m_]:=Select[ip@n,gap0Q@#&&(Max@#==m)&]

preμ0[n_,m_]:=Length@Gap0ByMax[n,m]-2Length@Select[Gap0ByMax[n,m],EvenQ@*Length]

μ0@M_:=PadRight[Table[preμ0[i,j],{i,M},{j,i}]]

1

gap1Q@x_:=DifferencesAtMostQ[-1][x]

Gap1ByMax[n_,m_]:=Select[ip@n,gap1Q@#&&(Max@#==m)&]

preμ1[n_,m_]:=Length@Gap1ByMax[n,m]-2Length@Select[Gap1ByMax[n,m],EvenQ@*Length]

μ1@M_:=PadRight[Table[preμ1[i,j],{i,M},{j,i}]]

2

gap2Q@x_:=DifferencesAtMostQ[-2][x]

Gap2ByMax[n_,m_]:=Select[ip@n,gap2Q@#&&(Max@#==m)&]

preμ2[n_,m_]:=Length@Gap2ByMax[n,m]-2Length@Select[Gap2ByMax[n,m],EvenQ@*Length]

μ2@M_:=PadRight[Table[preμ2[i,j],{i,M},{j,i}]]

3

gap3Q@x_:=DifferencesAtMostQ[-3][x]

Gap3ByMax[n_,m_]:=Select[IntegerPartitions@n,gap3Q@#&&(Max@#==m)&]

preμ3[n_,m_]:=Length@Gap3ByMax[n,m]-2Length@Select[Gap3ByMax[n,m],EvenQ@*Length]

μ3@M_:=PadRight[Table[preμ3[i,j],{i,M},{j,i}]]

4

gap4Q@x_:=DifferencesAtMostQ[-4][x]

Gap4ByMax[n_,m_]:=Select[IntegerPartitions@n,gap4Q@#&&(Max@#==m)&]

preμ4[n_,m_]:=Length@Gap4ByMax[n,m]-2Length@Select[Gap4ByMax[n,m],EvenQ@*Length]

μ4@M_:=PadRight@Table[preμ4[i,j],{i,M},{j,i}]

5

gap5Q@x_:=DifferencesAtMostQ[-5][x]

Gap5ByMax[n_,m_]:=Select[ip@n,gap5Q@#&&(Max@#==m)&]

preμ5[n_,m_]:=Length@Gap5ByMax[n,m]-2Length@Select[Gap5ByMax[n,m],EvenQ@*Length]

μ5@M_:=PadRight@Table[preμ5[i,j],{i,M},{j,i}]

6

gap6Q@x_:=DifferencesAtMostQ[-6][x]

Gap6ByMax[n_,m_]:=Select[ip@n,gap6Q@#&&(Max@#==m)&]

preμ6[n_,m_]:=Length@Gap6ByMax[n,m]-2Length@Select[Gap6ByMax[n,m],EvenQ@*Length]

μ6@M_:=PadRight@Table[preμ6[i,j],{i,M},{j,i}]

7

gap7Q@x_:=DifferencesAtMostQ[-7][x]

Gap7ByMax[n_,m_]:=Select[ip@n,gap7Q@#&&(Max@#==m)&]

preμ7[n_,m_]:=Length@Gap7ByMax[n,m]-2Length@Select[Gap7ByMax[n,m],EvenQ@*Length]

μ7@M_:=PadRight@Table[preμ7[i,j],{i,M},{j,i}]

gaps no 1

0 no 1

gap0no1Q@x_:=DifferencesAtMostQ[0][x]&&Not@MemberQ[x,1]

Gap0no1ByMax[n_,m_]:=Select[ip@n,gap0no1Q@#&&(Max@#==m)&]

preμ0no1[n_,m_]:=Length@Gap0no1ByMax[n,m]-2Length@Select[Gap0no1ByMax[n,m],EvenQ@*Length]

μ0no1@M_:=PadRight[Table[preμ0no1[i,j],{i,M},{j,i}]]

1 no 1

gap1no1Q@x_:=DifferencesAtMostQ[-1][x]&&Not@MemberQ[x,1]

Gap1no1ByMax[n_,m_]:=Select[ip@n,gap1no1Q@#&&(Max@#==m)&]

preμ1no1[n_,m_]:=Length@Gap1no1ByMax[n,m]-2Length@Select[Gap1no1ByMax[n,m],EvenQ@*Length]

μ1no1@M_:=PadRight[Table[preμ1no1[i,j],{i,M},{j,i}]]

2 no 1

gap2no1Q@x_:=DifferencesAtMostQ[-2][x]&&Not@MemberQ[x,1]

Gap2no1ByMax[n_,m_]:=Select[ip@n,gap2no1Q@#&&(Max@#==m)&]

preμ2no1[n_,m_]:=Length@Gap2no1ByMax[n,m]-2Length@Select[Gap2no1ByMax[n,m],EvenQ@*Length]

μ2no1@M_:=PadRight[Table[preμ2no1[i,j],{i,M},{j,i}]]

3 no 1

gap3no1Q@x_:=DifferencesAtMostQ[-3][x]&&Not@MemberQ[x,1]

Gap3no1ByMax[n_,m_]:=Select[IntegerPartitions@n,gap3no1Q@#&&(Max@#==m)&]

preμ3no1[n_,m_]:=Length@Gap3no1ByMax[n,m]-2Length@Select[Gap3no1ByMax[n,m],EvenQ@*Length]

μ3no1@M_:=PadRight[Table[preμ3no1[i,j],{i,M},{j,i}]]

4

gap4no1Q@x_:=DifferencesAtMostQ[-4][x]&&Not@MemberQ[x,1]

Gap4no1ByMax[n_,m_]:=Select[IntegerPartitions@n,gap4no1Q@#&&(Max@#==m)&]

preμ4no1[n_,m_]:=Length@Gap4no1ByMax[n,m]-2Length@Select[Gap4no1ByMax[n,m],EvenQ@*Length]

μ4no1@M_:=PadRight@Table[preμ4no1[i,j],{i,M},{j,i}]

5 no 1

gap5no1Q@x_:=DifferencesAtMostQ[-5][x]&&Not@MemberQ[x,1]

Gap5no1ByMax[n_,m_]:=Select[ip@n,gap5no1Q@#&&(Max@#==m)&]

preμ5no1[n_,m_]:=Length@Gap5no1ByMax[n,m]-2Length@Select[Gap5no1ByMax[n,m],EvenQ@*Length]

μ5no1@M_:=PadRight@Table[preμ5no1[i,j],{i,M},{j,i}]

6 no 1

gap6no1Q@x_:=DifferencesAtMostQ[-6][x]&&Not@MemberQ[x,1]

Gap6no1ByMax[n_,m_]:=Select[ip@n,gap6no1Q@#&&(Max@#==m)&]

preμ6no1[n_,m_]:=Length@Gap6no1ByMax[n,m]-2Length@Select[Gap6no1ByMax[n,m],EvenQ@*Length]

μ6no1@M_:=PadRight@Table[preμ6no1[i,j],{i,M},{j,i}]

7 no 1

gap7no1Q@x_:=DifferencesAtMostQ[-7][x]&&Not@MemberQ[x,1]

Gap7no1ByMax[n_,m_]:=Select[ip@n,gap7no1Q@#&&(Max@#==m)&]

preμ7no1[n_,m_]:=Length@Gap7no1ByMax[n,m]-2Length@Select[Gap7no1ByMax[n,m],EvenQ@*Length]

μ7no1@M_:=PadRight@Table[preμ7no1[i,j],{i,M},{j,i}]

EulerianNumber

EulerianNumber[n_,1]:=1

EulerianNumber[n_,n_]:=1

EulerianNumber[n_,k_]:=k Eulerian[n-1,k]+(n+1-k)Eulerian[n-1,k-1]

Losanitsch’s triangle
http://mathworld.wolfram.com/LosanitschsTriangle.html

LosanitschTriangle[n_,0]:=1
LosanitschTriangle[n_,n_]:=1
LosanitschTriangle[n_,k_]:=LosanitschTriangle[n,k]=LosanitschTriangle[n-1,k-1]+LosanitschTriangle[n-1,k]-Binomial[n/2-1,(k-1)/2]Mod[k,2]Mod[n-1,2]

CompletePartitionsByOnes, CompleteByOnes
CompletePartitionsByTwos

CompletePartitionsByOnes@n_:=Map[Row,SortBy[GatherBy[CompletePartitions[n],Length@Select[#,#==1&]&],Count[First[#],1]&],{2}]

CompletePartitionsByTwos@n_:=Map[Row,SortBy[GatherBy[CompletePartitions[n],Length@Select[#,#==2&]&],Count[First[#],2]&],{2}]

CompleteByOnes@n_:=Module[
{t},
t=Tally[Sort[Count[#,1]&/@CompletePartitions[n]]];Last/@Sort@Join[t,{#,0}&/@Complement[Range@n,First/@t]]
]

CompleteByTwos@n_:=Module[
{t},
t=Tally[Sort[Count[#,2]&/@CompletePartitions[n]]];Last/@Sort@Join[t,{#,0}&/@Complement[Range@n,First/@t]]
]

PartitionMu, DistinctPartitionsByMax, PartitionsMuByMax, OddDistinctPartitionsByMax, EvenDistinctPartitionsByMax

PartitionMu[λ_]:=0/;Sort@λ≠Union@λ

PartitionMu[λ_]:=(-1)^Length@λ/;Sort@λ==Union@λ

Define Ψ(n,m) to be the set of distinct partitions of n with largest part m, 1≤m≤n.

DistinctPartitionsByMax[n_,m_]:=DistinctPartitionsByMax[n,m]=Select[IntegerPartitions@n,(Sort@#==Union@#)&&(Max@#==m)&]

Let (Subscript[Ψ, o])(n,m) be the partitions in Ψ(n,m) of odd length and let and (Subscript[Ψ, e])(n,m) be those of even length.

Let (Subscript[ψ, n,m])=(Subscript[#Ψ, o])(n,m)-(Subscript[#Ψ, e])(n,m). (This is equivalent to mapping -(Subscript[μ, P]) over Ψ(n,m) and summing.) PartitionsMuByMax[n,m] calculates (Subscript[ψ, n,m]).

PartitionsMuByMax[n_,m_]:=PartitionsMuByMax[n,m]=Length@DistinctPartitionsByMax[n,m]-2Length@Select[DistinctPartitionsByMax[n,m],EvenQ@*Length]

PartitionsMuByMax@n_:=Table[PartitionsMuByMax[i,j],{i,n},{j,i}]

CompletePartitionsByMax[1,1]={{1}};

CompletePartitionsByMax[n_,m_]:=If[
m≤Floor[(n+1)/2],
Part[Reverse@GatherBy[GeneralizedCompletePartitions[n,1],First],m],
{}
]

OddDistinctPartitionsByMax[n_,m_]:=Select[IntegerPartitions@n,(Sort@#==Union@#)&&(Max@#==m)&&OddQ@Length@#&]

bad definition

OddDistinctPartitionsByMax@n_:=Table[Length@OddDistinctPartitionsByMax[i,j],{i,n},{j,i}]

EvenDistinctPartitionsByMax[n_,m_]:=Select[IntegerPartitions@n,(Sort@#==Union@#)&&(Max@#==m)&&EvenQ@Length@#&]

bad definition

EvenDistinctPartitionsByMax@n_:=Table[Length@EvenDistinctPartitionsByMax[i,j],{i,n},{j,i}]

NumberOfEvenDistinctPartitionsByMax, 
NumberOfOddDistinctPartitionsByMax

NumberOfEvenDistinctPartitionsByMax[n_,m_]:=NumberOfEvenDistinctPartitionsByMax[n,m]=Length@Select[DistinctPartitionsByMax[n,m],EvenQ@*Length]

NumberOfEvenDistinctPartitionsByMax@n_:=Table[NumberOfEvenDistinctPartitionsByMax[i,j],{i,n},{j,i}]

NumberOfEvenDistinctPartitionsByMax@20//Grid

NumberOfOddDistinctPartitionsByMax[n_,m_]:=NumberOfOddDistinctPartitionsByMax[n,m]=Length@Select[DistinctPartitionsByMax[n,m],OddQ@*Length]

NumberOfOddDistinctPartitionsByMax@n_:=Table[NumberOfOddDistinctPartitionsByMax[i,j],{i,n},{j,i}]

NumberOfOddDistinctPartitionsByMax@20//Grid

old CompleteByMax, PrependCompleteByMax

(*CompleteByMax[n_,1]:=1*)

(*CompleteByMax[n_,m_]:=Total@Table[CompleteByMax[n-m,j],{j,Min[m,(n-m+1)/2]}]*)

(*CompleteByMax@nn_:=Table[CompleteByMax[n,m],{n,nn},{m,(n+1)/2}]*)

(*PrependCompleteByMax[nn_]:=Prepend[
Prepend[
PadRight@Table[CompleteByMax[n,m],{n,nn},{m,(n+1)/2}],
Boole[#≤1]&/@Range[(nn+1)/2]
],
Table[0,(nn+1)/2]
]*)

CompleteInitial

CompleteInitial[k_]:=ReplacePart[Table[0,{n,2},{m,k}],{2,1}->1]

Earlier

Pascal

Pascal@n_:=Table[Binomial[m,k],{m,0,n-1},{k,0,n-1}]

Lower1

Lower1@n_:=Table[Boole[m≤k],{k,n},{m,n}]

𝒟, Doe

𝒟[n_,k_]:=𝒟[n,k]=Select[IntegerPartitions@n,(Sort@#==Union@#)&&(Max@#==k)&]

Doe[n_,k_]:=Doe[n,k]=Length@𝒟[n,k]-2Length@Select[𝒟[n,k],EvenQ@*Length]

Strip

Takes away upper zero matrix.

StripAux[x_,{n_}]:=Take[x,n]

Strip@m_:=MapIndexed[StripAux,m]

Strip@IdentityMatrix@5

StripFirstZeros@x_:=Drop[x,-1+First@First@Position[x,_?(#≠0&)]]

StripLastZeros@x_:=Take[x,First@Last@Position[x,_?(#≠0&)]]

StripZeros@x_:=StripLastZeros@StripFirstZeros@x

ConjugatePartition or tr

ConjugatePartition[l_List]:=Module[{i,r=Reverse[l],n=Length[l]},Table[n+1-Position[r,_?(#≥i&),Infinity,1][[1,1]],{i,l[[1]]}]]

tr=ConjugatePartition;

IntegerPartitionQ

IntegerPartitionQ@x_:=(And@@IntegerQ/@x)&&And@@(#<=0&/@Differences@x)

StrictCompositions@4

Select[StrictCompositions@4,IntegerPartitionQ]

BitsFromComposition, CompositionFromBits, ConjugateComposition, linear, conjlinear

BitsFromComposition@c_:=Flatten@Riffle[ConstantArray[0,#]&/@(c-1),1]

CompositionFromBits@b_:={1+Length@b}/;Not@MemberQ[b,1]

CompositionFromBits@b_:=Module[{f,m},
f=Flatten@Position[b,1];
m=Prepend[Differences@f,First@f];
Append[m,Length[b]+1-Total@m]
]

ConjugateComposition@c_:=CompositionFromBits[1-BitsFromComposition@c]

StrictCompositions@4

ConjugateComposition/@StrictCompositions@4

ConjugateComposition/@ConjugateComposition/@StrictCompositions@4

linear@c_:=Style[Row[Flatten@Riffle[Riffle[ConstantArray["—",#],"·"]&/@c,"|"]],24]

conjlinear@c_:=linear@c/.{"·"->"|","|"->"·"}

PartitionMu

Let muP(λ) be 0 if the partition λ has repeated parts and (((-1))^(l(λ))) otherwise.

PartitionMu[λ_]:=0/;Sort@λ≠Union@λ

PartitionMu[λ_]:=(-1)^Length@λ/;Sort@λ==Union@λ

muP=PartitionMu;

spt, SPT

spt@x_:=Count[#,Min[#]]&@x

SPT[n_]:=Total[Count[#,Min[#]]&/@IntegerPartitions@n]/;IntegerQ@n&&Positive@n

rank, crankω, crankμ, and crank

rank@λ_:=Max@λ-Length@λ

crankω[λ_]:=Count[λ,1]

crankμ[λ_]:=Count[#>crankω[λ]&/@λ,True]

crank[λ_]:=If[crankω[λ]>0,crankμ[λ]-crankω[λ],Max@λ]

rank/@IntegerPartitions[6]

crank/@IntegerPartitions[6]

drankaux@λ_:=First@λ-If[Length@λ>1,λ[[2]],0]

drank@λ_:=drankaux@λ-drankaux@ConjugatePartition@λ

LLP@{rank/@ip@12,crank/@ip@12,drank/@ip@12}

LLP@{Sort[rank/@ip@12],Sort[crank/@ip@12],Sort[drank/@ip@12]}

dis

Number of distinct parts.

dis@λ_:=Length@Union@λ

EO

±1 according to whether λ has an even or an odd number of parts.

EO@λ_:=(-1)^Length@λ

PartitionSubsums

PartitionSubsums[λ_,x_]:=Apply[Times,1+x^λ]

bisect, multisection, merge

bisect@x_:=Transpose@Partition[x,2]

trisect@x_:=Transpose@Partition[x,3]

multisection[x_,m_]:=Transpose@Partition[x,m]

multisection[Range@20,4]

merge[a_,b_]:=Flatten@Transpose@{a,b}

prespt, spt

prespt[λ] gives the number of appearances of the smallest part of λ.

prespt[λ_]:=Count[λ,Min@λ]

Let spt(n) denote the total number of appearances of the smallest parts in all the partitions of n. 
A092269 Spt function: total number of smallest parts in all partitions of n.

spt[n_]:=Total@Flatten[Count[#,Min@#]&/@IntegerPartitions@n]

spt/@Range@12

prespt/@IntegerPartitions[3]

prespt/@IntegerPartitions[10]

Total@%

spt[10]

prealtspt[λ_]:=(-1)^Length@λ Count[λ,Min@λ]

prealtspt/@IntegerPartitions[10]

altspt[n_]:=Total@Flatten[(-1)^Length@# Count[#,Min@#]&/@IntegerPartitions@n]

altspt/@Range@12

R, S, T, U, V, W, X,

rank[λ_]:=Max[λ]-Length[λ]

R5@k_:=Map[Length,Table[Table[Select[IntegerPartitions@n,m==Mod[rank@#,5]&],{m,0,4}],{n,k}],{2}]

S5@k_:=Map[Length@*Flatten,Table[Table[Select[IntegerPartitions@n,m==Mod[rank@#,5]&],{m,0,4}],{n,k}],{2}]

R7@k_:=Map[Length,Table[Table[Select[IntegerPartitions@n,m==Mod[rank@#,7]&],{m,0,6}],{n,k}],{2}]

S7@k_:=Map[Length@*Flatten,Table[Table[Select[IntegerPartitions@n,m==Mod[rank@#,7]&],{m,0,6}],{n,k}],{2}]

R11@k_:=Map[Length,Table[Table[Select[IntegerPartitions@n,m==Mod[rank@#,11]&],{m,0,10}],{n,k}],{2}]

S11@k_:=Map[Length@*Flatten,Table[Table[Select[IntegerPartitions@n,m==Mod[rank@#,11]&],{m,0,10}],{n,k}],{2}]

T5@k_:=Map[Length,Table[Table[Select[IntegerPartitions@n,m==Mod[crank@#,5]&],{m,0,4}],{n,k}],{2}]

U5@k_:=Map[ω@*Flatten,Table[Table[Select[IntegerPartitions@n,m==Mod[crank@#,5]&],{m,0,4}],{n,k}],{2}]

T7@k_:=Map[Length,Table[Table[Select[IntegerPartitions@n,m==Mod[crank@#,7]&],{m,0,6}],{n,k}],{2}]

U7@k_:=Map[ω@*Flatten,Table[Table[Select[IntegerPartitions@n,m==Mod[crank@#,7]&],{m,0,6}],{n,k}],{2}]

T11@k_:=Map[Length,Table[Table[Select[IntegerPartitions@n,m==Mod[crank@#,11]&],{m,0,10}],{n,k}],{2}]

U11@k_:=Map[ω@*Flatten,Table[Table[Select[IntegerPartitions@n,m==Mod[crank@#,11]&],{m,0,10}],{n,k}],{2}]

V13@k_:=Map[Length,Table[Table[Select[IntegerPartitions@n,m==Mod[prespt@#,13]&],{m,0,12}],{n,k}],{2}]

W13@k_:=Map[Length@*Flatten,Table[Table[Select[IntegerPartitions@n,m==Mod[prespt@#,13]&],{m,0,12}],{n,k}],{2}]

X13@k_:=Map[ω@*Flatten,Table[Table[Select[IntegerPartitions@n,m==Mod[prespt@#,13]&],{m,0,12}],{n,k}],{2}]

Y13@k_:=Map[dis@*Flatten,Table[Table[Select[IntegerPartitions@n,m==Mod[prespt@#,13]&],{m,0,12}],{n,k}],{2}]

Z13@k_:=Map[muP@*Flatten,Table[Table[Select[IntegerPartitions@n,m==Mod[prespt@#,13]&],{m,0,12}],{n,k}],{2}]

gap2ormoreQ and gap2ormore

gap2ormoreQ@λ_:=Apply[And,2≤#&/@-Differences@λ]

IntegerPartitions@6

Boole@*gap2ormoreQ/@IntegerPartitions@6

Row/@Select[IntegerPartitions@11,gap2ormoreQ]

gap2ormoreNo1Q@λ_:=Apply[And,(2≤#&/@-Differences@λ)&&Not@MemberQ[λ,1]]

gap3ormoreQ and gap3ormore

gap3ormoreQ@λ_:=Apply[And,3≤#&/@-Differences@λ]

gap3ormore@λ_:=Boole@gap3ormoreQ@λ

gap3ormorePartitions@n_:=Select[IntegerPartitions@n,gap3ormoreQ]

gap3ormore/@IntegerPartitions@6

gap3ormorePartitions@6

Total[gap3ormore/@IntegerPartitions@9]

gap3ormorePartitions@9

Residue14Mod5Q and Residue14Mod5
Residue14Mod5Partitions, Residue23Mod5Partitions
Residue23Mod5Q, Residue23Mod5

Residue1Mod5Q@λ_:=Apply[And,1==Mod[#,5]&/@λ]

Residue2Mod5Q@λ_:=Apply[And,2==Mod[#,5]&/@λ]

Residue3Mod5Q@λ_:=Apply[And,3==Mod[#,5]&/@λ]

Residue4Mod5Q@λ_:=Apply[And,4==Mod[#,5]&/@λ]

Residue14Mod5Q@λ_:=Apply[And,1==Mod[#,5]||4==Mod[#,5]&/@λ]

Residue14Mod5Partitions@n_:=Select[IntegerPartitions@n,Residue14Mod5Q]

Residue14Mod5@λ_:=Boole@Residue14Mod5Q@λ

Residue23Mod5Q@λ_:=Apply[And,2==Mod[#,5]||3==Mod[#,5]&/@λ]

Residue23Mod5Partitions@n_:=Select[IntegerPartitions@n,Residue23Mod5Q]

Residue23Mod5@λ_:=Boole@Residue23Mod5Q@λ

Ferrers

Ferrers@p_:=Framed@Grid[Table["●",#]&/@p]

EvenPartitionQ, OddPartitionQ and DistinctPartitionQ,
DistinctPartitionsNo1

EvenPartitionQ@λ_:=Apply[And,EvenQ/@λ]

OddPartitionQ@λ_:=Apply[And,OddQ/@λ]

DistinctPartitionQ@λ_:=Length@λ==Length@Union@λ

odd@λ_:=Boole@OddPartitionQ@λ

odd/@IntegerPartitions[6]

distinct@λ_:=Boole@DistinctPartitionQ@λ

DistinctPartitions@n_:=Select[ip@n,DistinctPartitionQ]

DistinctPartitions@5

OddPartitions@n_:=Select[ip@n,OddPartitionQ]

DistinctPartitionsNo1@n_:=Select[DistinctPartitions@n,Not@MemberQ[#,1]&]

DistinctPartitions@9

DistinctPartitionsNo1@9

NearDistinctPartitionQ

NearDistinctPartitionQ[k_,λ_]:=k==Length@λ-Length@Union@λ

Select[IntegerPartitions[6],NearDistinctPartitionQ[2,#]&]

DistinctEvenNumberOfPartsQ
and
DistinctOddNumberOfPartsQ

DistinctEvenNumberOfPartsQ@λ_:=EvenQ[Length@λ]&&DistinctPartitionQ@λ

DistinctOddNumberOfPartsQ@λ_:=OddQ[Length@λ]&&DistinctPartitionQ@λ

oo, dd, ooo, ddd from ‘parts of odd partitions.nb’

oo[k_]:=Table[Length@Flatten[Union/@Select[IntegerPartitions[n],OddPartitionQ]],{n,k}]

dd[k_]:=Table[Length@Flatten[Union/@Select[IntegerPartitions[n],DistinctPartitionQ]],{n,k}]

ooo[k_]:=Table[Total@Flatten[Union/@Select[IntegerPartitions[n],OddPartitionQ]],{n,k}]

ddd[k_]:=Table[Total@Flatten[Union/@Select[IntegerPartitions[n],DistinctPartitionQ]],{n,k}]

AllDistinctExceptAPairQ and AllDistinctExceptAPair

AllDistinctExceptAPairQ@λ_:=1==Count[Differences@λ,0]

ip@6

AllDistinctExceptAPairQ/@ip@6

AllDistinctExceptAPair@λ_:=Boole@AllDistinctExceptAPairQ@λ

from ‘Number of distinct odd parts.nb’

o@n_:=Length@Select[IntegerPartitions[n],Apply[And,OddQ@#]&]

od@n_:=Length@Select[IntegerPartitions[n],Apply[And,OddQ@#]&&Sort@#==Union@#&]

o/@Range[20]

A000009 		Expansion of Product_{m >= 1} (1 + x^m); number of partitions of n into distinct parts; number of partitions of n into odd parts (if n > 0).

od/@Range[20]

A000700 		Expansion of Product_{k>=0} (1 + x^(2k+1)); number of partitions of n into distinct odd parts; number of self-conjugate partitions; number of symmetric Ferrers graphs with n nodes.

dod@n_:=o@n-od@n

dod@n is the number of odd partitions of n with repetitions or the number of odd partitions that are not distinct.

dod/@Range[20]

convolution con
convolution inverse cinv
pent
pentagonaltransform

convolution[a_,b_]:=First/@Table[ListConvolve[Take[a,n],Take[b,n]],{n,Length@a}]

con=convolution;

convolution[{1,2,3},{aa,bb,cc}]

This is the convolution inverse.

cinvmatrix[x_]:=Reverse/@Table[Take[x,{1,n}],{n,Length@x}]

cinv[x_]:=Reverse@Last@Inverse@PadRight[Reverse/@Table[Take[x,{1,n}],{n,Length@x}]]

pent@n_:=cinv@PartitionsP@Range[0,n-1]

pent@40

pentagonaltransform@a_:=convolution[pent@Length@a,a]

SetPartitions3.nb

(* This loaded Combinatorica before. *)

AppendToEachInTurn::usage="AppendToEachInTurn[l,x] creates a list with the same length as l and where the elements of l have been appended by x, each in turn.";

AppendToEachInTurn[l_,x_]:=Table[MapAt[Append[#,x]&,l,n],{n,Length@l}]

SetPartitions::usage="SetPartitions[l,m] gives the partitions of the set l into m parts, treating the elements of the list l as distinguishable. The Length of SetPartitions[l,m] is StirlingS2[Length[l],m].";

SetPartitions[l_,1]:={{l}}

SetPartitions[l_,m_]:={}/;Length@l<m

SetPartitions[l_List, m_]:=Join[
Join[#,{{Last[l]}}]&/@SetPartitions[Drop[l,-1],m-1],
Flatten[AppendToEachInTurn[#,Last[l]]&/@SetPartitions[Drop[l,-1],m],1]
]

SetPartitions@l_:=Apply[Union,SetPartitions[l,#]&/@Range@Length@l]

DistinctSetPartitions::usage="DistinctSetPartitions[l,m] gives ways a list l can be partitioned into m sublists where the elements of l are considered indistinguishable if they are the same.";

DistinctSetPartitions[l_, m_] := Union[Sort /@SetPartitions[l, m]]

DistinctSetPartitions[l_]:=Flatten[DistinctSetPartitions[l,#]&/@Range[Length@l],1]

diff[l_]:=Drop[l,1]-Drop[l,-1]

MultisetWithFrequenciesGivenByPartition::usage="MultisetWithFrequenciesGivenByPartition[{a,b,c,...}] gives the multiset with a ones, b twos, c threes, ... .";

MultisetWithFrequenciesGivenByPartition[{}]={};

MultisetWithFrequenciesGivenByPartition[λ_]:=Join[MultisetWithFrequenciesGivenByPartition[Most[λ]],Table[Length@λ,{Last@λ}]]

MultisetWithFrequenciesGivenByPartition[{12}]

MultisetWithFrequenciesGivenByPartition[{1,2,2}]

MultisetWithFrequenciesGivenByPartition[{1,1,1,1,1,1,1,1}]

TotalNumberOfSetPartitionsPerNumberToBePartitioned[n_]:=Module[{ms},
ms=MultisetWithFrequenciesGivenByPartition/@IntegerPartitions[n];
Total[ Length[DistinctSetPartitions[ ms,# ]]&/@Range[n] ]
]

TotalNumberOfSetPartitionsPerNumberToBePartitioned/@Range[6]

NumberOfSetPartitionsOfMultiset[ms_]:=Length@Flatten[DistinctSetPartitions[ ms,# ]&/@Range[Length@ms],1]

SetPartitionsWithLengthsGivenBy[x_]:= Module[
{m},
m=SetPartitions @ Range @ Total @ x;
m[[ 
Flatten@Position[
Sort/@Map[ Length,m,{2}],
Sort@x
]
]]
]

MultisetFromPartition::usage="MultisetFromPartition[λ], where λ is a partition {λ1,λ2,λ3,...}, gives the list {1,1,1,...,2,2,...,3,3,...}, where there are λ1 1's, λ2 2's, etc. The partition λ represents the objects {1,2,3,..} that have multiplicities {λ1,λ2,λ3,...}.";

MultisetFromPartition[{}]:={}

MultisetFromPartition[λ_]:=Join[
MultisetFromPartition[Drop[λ,-1]],
Length[λ] 1^Range[Last[λ]]
]

repeatCompletePartitions,
OddCompletePartitions,
EvenCompletePartitions,
DifferenceTally

repeatCompletePartitions[x_,{n_}]:=Table[CompletePartitions[n],{x}]

OddCompletePartitions@n_:=OddCompletePartitions@n=Sort@Flatten[
MapIndexed[
repeatCompletePartitions,
Table[NumberOfOddDistinctPartitionsByMax[n+2,nn],{nn,3,n+2}]
],
2]

OddCompletePartitions@5

EvenCompletePartitions@n_:=EvenCompletePartitions@n=Sort@Flatten[
MapIndexed[
repeatCompletePartitions,
Table[NumberOfEvenDistinctPartitionsByMax[n+2,nn],{nn,3,n+2}]
],
2]

EvenCompletePartitions@5

tallyaux@Tally@Flatten@OddCompletePartitions@5

DifferenceTally@n_:=DifferenceTally@n=Subtract@@PadRight[
{
tallyaux@Tally@Flatten@OddCompletePartitions@n,
tallyaux@Tally@Flatten@EvenCompletePartitions@n
}
]

Clear@DifferenceTally

DifferenceTally@5

Table[DifferenceTally@n,{n,2,7}]//Grid

intersection@n_:=Intersection[OddCompletePartitions@n,EvenCompletePartitions@n]

splitcount@n_:=Module[{a,b},
a=Row/@OddCompletePartitions@n;
b=Row/@EvenCompletePartitions@n;
Length/@{
multisetComplement[a,b],
multisetIntersection[a,b],
multisetComplement[b,a]
}]

Subsum polynomial sp

sp[list_,x_]:=Apply[Times,1+x^list]

sp[{3,1,1},xx]

PartitionUnion, odddotterm, evendotterm, odddot, evendot, matchoddeven

PartitionUnion=Reverse@*Sort@*multisetUnionSum;

odddotterm[m_,k_]:=Flatten[
Outer[
List,
OddDistinctPartitionsByMax[m,k+2],
CompletePartitions@k,
1],
1]

evendotterm[m_,k_]:=Flatten[
Outer[
List,
EvenDistinctPartitionsByMax[m,k+2],
CompletePartitions@k,
1],
1]

odddot@m_:=Table[odddotterm[m,k],{k,m}]

evendot@m_:=Table[evendotterm[m,k],{k,m}]

matchoddeven@n_:=Module[
{kk=Length[Flatten[odddot@n,1]]},
Transpose@{
Map[Row,Flatten[odddot@n,1],{2}],
Table[Spacer[40],{kk}],
Map[Row,Flatten[evendot@n,1],{2}]}//grid
]

tallyo, tallye, tallyoe

tallyo@n_:=Module[
{o},
o=Flatten[odddot@n,1];
Reverse@Sort[
Transpose@{
Row@(PadRight[tallyaux@*Tally@*Flatten@#,n]/. 0->"·")&/@o,
Table[Spacer[5],{Length@o}],
Map[Row,o,{2}],
Table[Spacer[5],{Length@o}],
Total@*Last/@o
}
]
]

tallye@n_:=Module[
{e},
e=Flatten[evendot@n,1];
Reverse@Sort[
Transpose@{
Row@(PadRight[tallyaux@*Tally@*Flatten@#,n]/. 0->"·")&/@e,
Table[Spacer[5],{Length@e}],
Map[Row,e,{2}],
Table[Spacer[5],{Length@e}],
Total@*Last/@e
}
]
]

tallyoe@n_:=Row[{tallyo@n//Grid,Spacer[50],tallye@n//Grid}]

Subcompletes, SplitDistinct, SplitDistinctSubcompletes

Subcompletes::usage="Subcompletes[c] gives the list of all possible pairs of the form {x,t} where x is a part of c and t = c\\x is complete. In other words, a part x is split off from c such that what is left t is complete.";

Subcompletes@c_:=Select[Transpose@{Union@c,multisetComplement[c,{#}]&/@Union@c},CompletePartitionQ@*Last]

example

Subcompletes@{6,3,2,2,1}

SplitDistinct::usage="SplitDistinct[d] for d a distinct partition, gives a list of of all possible triples {x,y,z}, where x+y is a part of d, z = d\(x+y) and {x}⊔{y}⊔z is distinct. In other words, split a part x+y of w into pieces x and y such that the new partition is still distinct."

SplitDistinctAux[w_,x_]:=
Select[
Table[PartitionUnion[multisetComplement[w,{x}],{k,x-k}],{k,x/2}],DistinctPartitionQ
]/;MemberQ[w,x]

SplitDistinctAux[w_,x_]:=
Select[
Table[{k,x-k,multisetComplement[w,{x}]},{k,x/2}],DistinctPartitionQ@*PartitionUnion@Flatten@#&
]/;MemberQ[w,x]

SplitDistinctAux[{7,5,1},1]

DistinctPartitionQ@{7,5,1}

SplitDistinctAux[{7,5,1},5]

SplitDistinctAux[{7,5,1},7]

SplitDistinct@w_:=Flatten[SplitDistinctAux[w,#]&/@Union@w,1]

SplitDistinct@{7,5,1}

Row/@DistinctPartitions@13

SplitDistinct/@DistinctPartitions@13//Column

SplitDistinctSubcompletes::usage="SplitDistinctSubcompletes@{d,c}, where d is a distinct partition and c is a complete partition, is a list of pairs {d1, c1} of the same kind as {d, c}, where d1 is a split distinct {x, y, z} of d and c1 is a subcomplete {x, t} of c."

SplitDistinctSubcompletes@{d_,c_}:=Module[
{ggg,hhh},
Select[
Flatten[Outer[List,ggg/@SplitDistinct@d,hhh/@Subcompletes@c],1],
#[[1,1,1]]==#[[2,1,1]]&
]/.ggg->Reverse@*Sort@*Flatten
/.hhh->Last
]

c={7,3,2,2,1,1};

sc=Subcompletes@c

fsc=First/@sc

d={9,3,1};

sd=SplitDistinct@d

ssd=Select[sd,MemberQ[fsc,First@#]&]

ssc=Select[sc,MemberQ[First/@ssd,First@#]&]

{PartitionUnion@Flatten@ssd,Last/@ssc}

d={10,3};

sd=SplitDistinct@d

Select[
Flatten[Outer[List,ggg/@sd,hhh/@sc],1],
#[[1,1,1]]==#[[2,1,1]]&
]

{PartitionUnion@Flatten@ssd,Last/@ssc}

pair[{1,aa},{1,bb}][[1]]

Length/@{sd,sc}

Flatten[Outer[List,ggg/@sd,hhh/@sc],1]

{ggg[{1,2,{10}}],hhh[{1,{7,3,2,2,1}}]}[[1,1,1]]

{ggg[{1,2,{10}}],hhh[{1,{7,3,2,2,1}}]}[[2,1,1]]

sel=Select[
Flatten[Outer[List,ggg/@sd,hhh/@sc],1],
#[[1,1,1]]==#[[2,1,1]]&
]

c

d

sel/.ggg->Reverse@*Sort@*Flatten/.hhh->Last

SplitDistinctSubcompletes@{{10,3},{7,3,2,2,1,1}}

sign

sign@n_:=Table[(-1)^(i+j),{i,n},{j,i}]

sign@4//grid

tr, gl, fr, uv, vu, sy, wi,

extract of Combinatorica 2003

http://homepage.cs.uiowa.edu/~sriram/Combinatorica/NewCombinatorica.m

binarysearchchore[l_,k_,f_]:=Module[{lo=1,mid,hi=Length[l],el},While[lo≤hi,If[(el=f[l[[mid=Floor[(lo+hi)/2]]]])===k,Return[mid]];
If[!NumericQ[el],(Message[BinarySearch::error];Return[$Failed])];
If[el>k,hi=mid-1,lo=mid+1]];
Return[lo-1/2]];

BinarySearch[l_?(Length[#1]>0&),k_?NumericQ,f_:Identity]:=With[{res=binarysearchchore[l,k,f]},res/;res=!=$Failed]

DeleteFromTableau[t1_?TableauQ,r_Integer]:=Module[{t=t1,col,row,item=Last[t1[[r]]]},col=Length[t[[r]]];
If[col==1,t=Drop[t,-1],t[[r]]=Drop[t[[r]],-1]];
Do[While[t[[row,col]]≤item&&Length[t[[row]]]>col,col++];
If[item<t[[row,col]],col--];
{item,t[[row,col]]}={t[[row,col]],item},{row,r-1,1,-1}];
t]

InsertIntoTableau[e_Integer,t_?TableauQ]:=First[InsertIntoTableau[e,t,All]]

InsertIntoTableau[e_Integer,{},All]:={{{e}},1}

InsertIntoTableau[e_Integer,t1_?TableauQ,All]:=Module[{item=e,row=0,col,t=t1},While[row<Length[t],row++;If[Last[t[[row]]]≤item,AppendTo[t[[row]],item];Return[{t,row}]];col=Ceiling[BinarySearch[t[[row]],item]];{item,t[[row,col]]}={t[[row,col]],item};];{Append[t,{item}],row+1}]

PermutationQ[e_List]:=Sort[e]===Range[Length[e]]

PermutationToTableaux[{}]:={{},{}}

PermutationToTableaux[p_?PermutationQ]:=Module[{pt={{p[[1]]}},qt={{1}},r,i},Do[{pt,r}=InsertIntoTableau[p[[i]],pt,All];If[r≤Length[qt],AppendTo[qt[[r]],i],AppendTo[qt,{i}]],{i,2,Length[p]}];{pt,qt}]

TransposePartition[{}]:={}

TransposePartition[p_List]:=Module[{s=Select[p,(#>0)&],i,row,r},row=Length[s];
Table[r=row;While[s[[row]]≤i,row--];r,{i,First[s]}]]

TransposeTableau[tb_List]:=Module[{t=Select[tb,(Length[#]≥1)&],row},Table[row=Map[First,t];
t=Map[Rest,Select[t,(Length[#]>1)&]];
row,{Length[First[tb]]}]]

ShapeOfTableau[t_List]:=Map[Length,t]

TableauClasses[p_?PermutationQ]:=Module[{classes=Table[{},{Length[p]}],t={}},Scan[(t=InsertIntoTableau[#,t];
PrependTo[classes[[Position[First[t],#][[1,1]]]],#])&,p];
Select[classes,(#≠{})&]]

TableauQ[{}]=True;

TableauQ[t_List]:=And[Apply[And,Map[(Apply[LessEqual,#])&,t]],Apply[And,Map[(Apply[LessEqual,#])&,TransposeTableau[t]]],Apply[GreaterEqual,ShapeOfTableau[t]],Apply[GreaterEqual,Map[Length,TransposeTableau[t]]]]

TableauToYVector[t_?TableauQ]:=Module[{i,y=Table[1,{Length[Flatten[t]]}]},Do[Scan[(y[[#]]=i)&,t[[i]]],{i,2,Length[t]}];
y]

FirstLexicographicTableau[s_List]:=TransposeTableau[LastLexicographicTableau[TransposePartition[s]]]

LastLexicographicTableau[s_List]:=Module[{c=0},Map[(c+=#;Range[c-#+1,c])&,s]]

ConstructTableau[p_List]:=Module[{T},T[a_,b_]:=InsertIntoTableau[b,a];Fold[T,{},p]]

Tableaux[s_List]:=Module[{t=LastLexicographicTableau[s]},Table[t=NextTableau[t],{NumberOfTableaux[s]}]]

Tableaux[n_Integer?Positive]:=Apply[Join,Map[Tableaux,IntegerPartitions[n]]]

TableauxToPermutation[p1_?TableauQ,q1_?TableauQ]:=Module[{p=p1,q=q1,row,firstrow},Reverse[Table[firstrow=First[p];
row=Position[q,Max[q]][[1,1]];
p=DeleteFromTableau[p,row];
q[[row]]=Drop[q[[row]],-1];
If[p=={},First[firstrow],First[Complement[firstrow,First[p]]]],{Apply[Plus,ShapeOfTableau[p1]]}]]]/;ShapeOfTableau[p1]===ShapeOfTableau[q1]

NextTableau[t_?TableauQ]:=Module[{s,y,row,j,count=0,tj,i,n=Max[t]},y=TableauToYVector[t];
For[j=2,(j<n)&&(y[[j]]≥y[[j-1]]),j++];
If[y[[j]]≥y[[j-1]],Return[FirstLexicographicTableau[ShapeOfTableau[t]]]];
s=ShapeOfTableau[Table[Select[t[[i]],(#≤j)&],{i,Length[t]}]];
{row}=Last[Position[s,s[[Position[t,j][[1,1]]+1]]]];
s[[row]]--;
tj=FirstLexicographicTableau[s];
If[Length[tj]<row,tj=Append[tj,{j}],tj[[row]]=Append[tj[[row]],j]];
Join[Table[Join[tj[[i]],Select[t[[i]],(#>j)&]],{i,Length[tj]}],Table[t[[i]],{i,Length[tj]+1,Length[t]}]]]

NumberOfTableaux[{}]:=1

NumberOfTableaux[s_List]:=Module[{row,col,transpose=TransposePartition[s]},(Apply[Plus,s])!/Product[(transpose[[col]]-row+s[[row]]-col+1),{row,Length[s]},{col,s[[row]]}]]

NumberOfTableaux[n_Integer]:=Apply[Plus,Map[NumberOfTableaux,IntegerPartitions[n]]]

RandomSquare[y_List,p_List]:=Module[{i=Random[Integer,{1,First[y]}],j=Random[Integer,{1,First[p]}]},While[(i>y[[j]])||(j>p[[i]]),i=Random[Integer,{1,First[y]}];
j=Random[Integer,{1,First[p]}]];
{i,j}]

RandomTableau[shape_List]:=Module[{i=j=n=Apply[Plus,shape],done,l,m,h=1,k,y,p=shape},y=Join[TransposePartition[shape],Table[0,{n-Max[shape]}]];
Do[{i,j}=RandomSquare[y,p];done=False;
While[!done,h=y[[j]]+p[[i]]-i-j;
If[h≠0,If[Random[]<0.5,j=Random[Integer,{j,p[[i]]}],i=Random[Integer,{i,y[[j]]}]],done=True];];
p[[i]]--;y[[j]]--;
y[[m]]=i,{m,n,1,-1}];
YVectorToTableau[y]]

YVectorToTableau[y_List]:=Module[{k},Table[Flatten[Position[y,k]],{k,Length[Union[y]]}]]

SemiFibonacci

SemiFibonacci[1]=1;
SemiFibonacci[n_]:=SemiFibonacci[n]=SemiFibonacci[n/2]/;EvenQ[n]
SemiFibonacci[n_]:=SemiFibonacci[n]=SemiFibonacci[n-1]+SemiFibonacci[n-2]/;OddQ[n]

SemiFibonacciPartitions[1]={{1}};

SemiFibonacciPartitions[m_]:=2SemiFibonacciPartitions[m/2]/;EvenQ@m

SemiFibonacciPartitions[m_]:=Union[
Append[#,1]&/@SemiFibonacciPartitions[m-1],
Reverse@Sort@Union[Select[#,EvenQ],2+Select[#,OddQ]]&/@SemiFibonacciPartitions[m-2] 
]/;OddQ@m

RandomPartition

RandomPartition[n_]:=IntegerPartitions[n][[RandomInteger[PartitionsP[n]]]]

ConjugatePartition or tr

ConjugatePartition[l_List]:=Module[{i,r=Reverse[l],n=Length[l]},Table[n+1-Position[r,_?(#≥i&),Infinity,1][[1,1]],{i,l[[1]]}]]

tr[l_List]:=Module[{i,r=Reverse[l],n=Length[l]},Table[n+1-Position[r,_?(#≥i&),Infinity,1][[1,1]],{i,l[[1]]}]]

OppositePartition in the Lexicographic Order

OppositePartition@p_:=Module[{ps=IntegerPartitions@Total@p},ps[[First[1+PartitionsP@Total@p-First@Position[ps,p]]]]
]

DifferenceTable

DifferenceTable@x_:=NestList[Differences,x,-1+Length@x]

Franklin’s α, here fr

DiagonalLength

Number of parts starting from the first part that differ by 1.

DiagonalLength[p_]:=Module[{TrueFalseList},
TrueFalseList=Equal@@@Transpose[{Table[-1,{i,Length@p-1}],Differences@p}];
If[
Not@MemberQ[TrueFalseList,False],
Length@p,
First@FirstPosition[TrueFalseList,False]
]
]

IntegerPartitions@5

DiagonalLength/@IntegerPartitions@5

stayput

If s=DiagonalLength or s=DiagonalLength+1 and the lines have a common square, stay put. n=m(3m±1)/2

stayput[p_]:=(Total@p==m(3m+1)/2/.m->Last@p-1)||(Total@p==m(3m-1)/2/.m->Last@p)

pentagonalQ

pentagonalQ1[p_]:=Or[
1/2(First@p+1)==Length@p==Last@p,
1/2First@p==Length@p==Last@p-1
]

pentagonalQ[p_]:=pentagonalQ1@p||pentagonalQ1@ConjugatePartition@p

down

Let s be the smallest (and last) part. If s>DiagonalLength+1, move the diagonal line down below the horizontal line.

down[p_]:=Append[PadRight[Table[-1,{DiagonalLength@p}],Length@p]+p,DiagonalLength@p]

up

If s<DiagonalLength, move the horizontal line up into the diagonal line.

up[p_]:=PadRight[Table[1,{Last@p}],Length@p-1]+Most@p

DistinctPartitionQ, DistinctPartitions

DistinctPartitionQ[p_]:=Length@p==Length@Union@p

DistinctPartitions[n_]:=Select[IntegerPartitions@n,DistinctPartitionQ]

fr

fr[p_]:=If[
Not@DistinctPartitionQ@p||pentagonalQ@p,
p,
If[Last@p≤DiagonalLength@p,up@p,down@p]
]

rank

rank@p_:=p[[1]]-Length@p

ReflectedParts

This counts how many rows of p starting at the first are in the conjugate of p. It can range from 0 to the first part of p.

??ReflectedParts

ReflectedParts@{}=0;

ReflectedParts@p_:=If[Length@p≠First@p,0,1+ReflectedParts[DeleteCases[Rest@p-1,0]]]

ReflectedParts/@ip@5

ip@5

ReflectedParts/@ip@6

ReflectedParts/@ip@7

ReflectedParts/@ip@8

ReflectedParts/@ip@9

Glaisher’s odd ⟷ distinct involution gl (or gl[p, 2])

TwoPowers

TwoPowers[alist_]:=
Table[2^n,{n,Length@alist-1,0,-1}]alist

DistinctFromOdd

DistinctFromOdd[p_]:=Module[
{nf,tp,i},
nf={First@#,Length@#}&/@Split@Sort[p,Greater];(* number-frequency *)
tp=TwoPowers@IntegerDigits[Last@#,2]&/@nf;
Sort[DeleteCases[Flatten@Table[tp[[i]]nf[[i,1]],{i,Length@nf}],0],Greater]
]

GlaisherOD=DistinctFromOdd;

a=Table[Length@Union[DistinctFromOdd/@ip@n],{n,24}]

LLP@a

{u,v}=bisect@a

v-u

u+v

OddFromDistinct

OddFromDistinctAux[x_]:={x}/;OddQ[x]

OddFromDistinctAux[x_]:=Module[{a,b},
{{a,b}}=Cases[FactorInteger[x],{2,_}];
Table[x/2^b,{n,2^b}]
]

OddFromDistinct[p_]:=Sort[Flatten[OddFromDistinctAux/@p],Greater]

GlaisherDO=OddFromDistinct;

OddPartitionQ

OddPartitionQ[p_]:=And@@OddQ@p

DistinctPartitionQ

DistinctPartitionQ[p_]:=p==DeleteDuplicates@p

gl

gl@p_:=Which[
OddPartitionQ@p,DistinctFromOdd@p,
DistinctPartitionQ@p,OddFromDistinct@p,
True,p
]

order

order, the least integer m for which (f^m) is the identity.

order[f_,n_]:=Length@NestWhileList[f/@#&,f/@ip@n,#=!=ip@n&]

If x and y are involutions, order(x∘y)=order(y∘x), because
(((y x))^n)=y ((x(y x))^(n-1))y y= y (((x y))^n)y=y y = 1.

If x, y, z are involutions and order(x y z) = n, then
(((z x y))^n)=z x y (((z x y))^(n-1))z z=z (((x y z))^n)z=z 1 z=1
so order(z x y)=n and order(y z x)=n, too.

Also, (z y x)^n = ((((((x y z))^(-1))))^n)=((((((x y z))^n)))^(-1))=1, so order(z y x)=order(x z y)=order(y x z). That is, all six possible permutations of the product of three involutions have the same order.

If w, x, y, z are involutions and order(w x y z) = n, then the same argument as for three involutions shows that eight permutations of the product of the four involutions are the same.

gl[p, k]

gl[p, k]: not divisible by k ⟷ no part appears more than k times

SpreadPowers

SpreadPowers[alist_,k_]:=Flatten@Table[Table[k^(Length[alist]-n),{m,alist[[n]]}],{n,Length@alist}]

AtMostkMinus1FromNotDivisibleByk

AtMostkMinus1FromNotDivisibleByk[p_,k_]:=p/;AtMostkMinus1Q[p,k]

AtMostkMinus1FromNotDivisibleByk[p_,k_]:=Module[
{nf,tp,i},
nf={First@#,Length@#}&/@Split@Sort[p,Greater];(* number-frequency *)
tp=SpreadPowers[IntegerDigits[Last@#,k],k]&/@nf;
Sort[DeleteCases[Flatten@Table[tp[[i]]nf[[i,1]],{i,Length@nf}],0],Greater]
]

AtMostkMinus1FromNotDivisibleByk[p_,k_]:=If[
AtMostkMinus1Q[p,k],p,
Module[
{nf,tp,i},
nf={First@#,Length@#}&/@Split@Sort[p,Greater];(* number-frequency *)
tp=SpreadPowers[IntegerDigits[Last@#,k],k]&/@nf;
Sort[DeleteCases[Flatten@Table[tp[[i]]nf[[i,1]],{i,Length@nf}],0],Greater]
]
]

NotDivisibleBykFromAtMostkMinus1

NotDivisibleBykFromAtMostkMinus1Aux[x_,k_]:={x}/;Not@Divisible[x,k]

NotDivisibleBykFromAtMostkMinus1Aux[x_,k_]:=Module[{a,b},
{{a,b}}=Cases[FactorInteger[x],{k,_}];
Table[x/k^b,{n,k^b}]
]

NotDivisibleBykFromAtMostkMinus1Aux[x_,k_]:=Module[{b},
b=IntegerExponent[x,k];
Table[x/k^b,{n,k^b}]
]

NotDivisibleBykFromAtMostkMinus1[p_,k_]:=p/;NotDivisibleBykQ[p,k]

NotDivisibleBykFromAtMostkMinus1[p_,k_]:=Sort[Flatten[NotDivisibleBykFromAtMostkMinus1Aux[#,k]&/@p],Greater]

NotDivisibleBykQ

NotDivisibleBykQ[p_,k_]:=Apply[And,0=!=Mod[#,k]&/@p]

AtMostkMinus1Q

AtMostkMinus1Q[p_,k_]:=k>Max[Last/@Tally@p]

gl[p, k]

gl[p_,k_]:=Which[
NotDivisibleBykQ[p,k],AtMostkMinus1FromNotDivisibleByk[p,k],
AtMostkMinus1Q[p,k],NotDivisibleBykFromAtMostkMinus1[p,k],
True,p
]

gl2=gl[#,2]&;

gl3=gl[#,3]&;

gl4=gl[#,4]&;

gl5=gl[#,5]&;

Bressoud-Zeilberger ϕ[{j,p}]

bzb[j_]:=(3j^2+j)/2

ϕ@{j_,p_}:=Module[{t,p1},
p1=First@p;
t=Length@p;
If[
t+3j≥p1,
{j-1,DeleteCases[Prepend[p-1,t+3j-1],0]},
{j+1,Join[Rest[p]+1,Table[1,{n,p1-t-3j-1}]]}
]
]

AllEven, even-even, ev[p] (Pak The Nature of Partition Bijections II, p. 13)

AllEven[p_]:=And@@EvenQ/@p

ev[p_]:=p/;Not@AllEven@p

ev[p_]:=ConjugatePartition@Sort[Join[p/2,p/2],Greater]

Similarly do ≡ 0 (mod m)

Hook

HookAux[n_,{z_}]:=PadLeft[Join[{Ceiling[(n/2)]},Table[1,{k,Floor[(n/2)]}]],z+Floor[(n/2)]]

Hook[p_]:=Sort[Total[PadRight@MapIndexed[HookAux,p]],Greater]

(* old and wrong: Hook[p_]:=Sort[DeleteCases[Total[PadRight[#,Max[Length@p,First@p]]&/@MapIndexed[HookAux,p]],0],Greater] *)

testHook[n_]:=Transpose@{Select[IntegerPartitions@n,OddPartitionQ],Hook/@Select[IntegerPartitions@n,OddPartitionQ]}//Column

Hooks

Hooks@x_:=Plus@@#+1^Length@#&[FrobeniusSymbol@x]

IntegerPartitions@6

Hooks/@IntegerPartitions@6

OneOrFourMod5, PartitionsMod14, SuccessivePartsDifferByAtLeast2

OneOrFourMod5[p_]:=And@@(Mod[#1,5]==1||Mod[#1,5]==4&)/@p

PartitionsMod145@n_:=IntegerPartitions[n,All,Union[Table[5k+1,{k,0,Floor[(n-1)/5]}],Table[5k+4,{k,0,Floor[n/5]}]]]

PartitionsMod235@n_:=IntegerPartitions[n,All,Union[Table[5k+2,{k,0,Floor[(n-1)/5]}],Table[5k+3,{k,0,Floor[n/5]}]]]

PartitionsMod14@16

Mod14@n_:=Select[Flatten@Table[{5k+1,5k+4},{k,0,Floor[(n-1)/5]}],#≤n&]

Mod14/@Range@15//Column

SuccessivePartsDifferByAtLeast2[p_]:=And@@(-#1>1&)/@Differences[p]

Table[Length@PartitionsMod145@n,{n,24}]

modify bends

If a part is
5n+1 ⟶ 5n+1
5n+2 ⟶ 5n+1  1
5n+3 ⟶ 5n+1 11
5n+4 ⟶ 5n+4
5n ⟶ 5(n-1)+4  1

modifyAux@z_:=Switch[Mod[z,5],0,{5(z/5-1)+4,1},1,{z},2,{z-1,1},3,{z-2,1,1},4,{z}]

Partition[modifyAux/@Range@30,5]//Column

(* old: modify@p_:=Sort[Apply[Join,modifyAux/@p],Greater]*)

modifyAux2@{x_,0}:=Flatten@{modifyAux@x}

modifyAux2@{x_,y_}:=Flatten@Join[modifyAux/@{x,y}]/;x>y(* or ">" ? *)

modifyAux2@{x_,y_}:=Flatten@Module[{z},z=modifyAux@x;Join[z,modifyAux2@{Max@z,y-Max@z}]  ]/;x≤y

modify@x_:=Flatten[modifyAux2/@x]

missing@n_:=Complement[PartitionsMod14@n,Sort[#,Greater]&/@(modify/@Stems/@PartitionsMod14@n)]

modify bends 2

modify2Aux@z gives the shortest partition with smallest possible part into parts congruent to 1 or 4 (mod 5) of z.

modify2Aux@z_:=First@SortBy[IntegerPartitions[#,All,Mod14@#]&@z,Length]

modify2Aux/@Range@21

modify2Aux2@{x_,0}:=Flatten@{modify2Aux@x}

modify2Aux2@{x_,y_}:=Flatten@Join[modify2Aux/@{x,y}]/;x>y(* or ">" ? *)

modify2Aux2@{x_,y_}:=Flatten@Module[{z},z=modify2Aux@x;Join[z,modify2Aux2@{Max@z,y-Max@z}]  ]/;x≤y

modify2@x_:=Flatten[modify2Aux2/@x]

modify bends 3

tuples[n] gives all possible lists of partitions with the following properties. If x is such a list, x has length n and x[[k]] is a partition of k into parts congruent to 1 or 4 (mod 5).

tuples@n_:=tuples@n=Tuples[IntegerPartitions[#,All,Mod14@#]&/@Range@n]

modify3Aux[k, m, n] gives the m-th term of the k-th tuple for n; modify3Aux[k, m, n] is a partition of m into parts congruent to 1 or 4 (mod 5).

modify3Aux[k_,m_,n_]:=tuples[n][[k,m]]

modify3Aux[1,1,1]

modify3Aux[1,1,2]

modify3Aux[1,2,2]

modify3Aux[1,1,3]

modify3Aux[1,2,3]

modify3Aux[1,3,3]

modify3Aux[1,1,4]

modify3Aux[2,1,4]

modify3Aux[1,2,4]

modify3Aux[2,2,4]

modify3Aux[1,3,4]

modify3Aux[2,3,4]

modify3Aux[1,4,4]

modify3Aux[2,4,4]

tuples@4//Column

modify3Aux2[k_,{m_,0},n_]:=Flatten@{modify3Aux[k,m,n]}

modify3Aux2[k_,{x_,y_},n_]:=Flatten@Join[modify3Aux[k,#,n]&/@{x,y}]/;x>y(* or ">" ? *)

modify3Aux2[k_,{x_,y_},n_]:=Flatten@Module[{z},z=modify3Aux[k,x,n];Join[z,modify3Aux2[k,{Max@z,y-Max@z},n]]  ]/;x≤y

modify3Aux[k_,m_,n_]:=tuples[n][[k,m]]

modify3[k_,x_,n_]:=Flatten[modify3Aux2[k,#,n]&/@x]

missing3[k_,n_]:=Complement[PartitionsMod14@n,Sort[#,Greater]&/@(modify3[k,#,n]&/@Stems/@PartitionsMod14@n)]

table[k_,n_]:=Grid[Transpose@{PartitionsMod14@n,Stems/@PartitionsMod14@n,modify3[k,#,n]&/@Stems/@PartitionsMod14@n},Alignment->Left]

gives[n_,xx_]:=tuples[n][[Select[Range@Length@tuples[n],xx==missing3[#,n]&]]]

modify3Aux[1,All,12]

modify3Aux[2,All,12]

modify bends 13

modify13Aux[a_,k_,m_,n_]:=(Append[modify3Aux[a,All,12],#]&/@IntegerPartitions[n,All,Mod14@n])[[k,m]]

modify13Aux2[a_,k_,{m_,0},n_]:=Flatten[{modify13Aux[a,k,m,n]}]

modify13Aux2[a_,k_,{x_,y_},n_]:=Flatten[Join[(modify13Aux[a,k,#1,n]&)/@{x,y}]]/;x>y

modify13Aux2[a_,k_,{x_,y_},n_]:=Flatten[Module[{z},z=modify13Aux[a,k,x,n];Join[z,modify13Aux2[a,k,{Max[z],y-Max[z]},n]]]]/;x≤y

modify13[a_,k_,m_,n_]:=Flatten[(modify13Aux2[a,k,#1,n]&)/@m]

missing13[a_,k_,n_]:=Complement[PartitionsMod14[n],(Sort[#1,Greater]&)/@(modify13[a,k,#1,n]&)/@Stems/@PartitionsMod14[n]]

IntegerPartitions[13,All,Mod14@13]

IntegerPartitions[13,All,Mod14@13][[#]]&/@Range@10

bu Bulgarian Solitaire move

bu@p_:=DeleteCases[Sort[Prepend[p-1,Length@p],Greater],0]

ip@5

bu/@ip@5

Hook2

Hook2Aux[n_,{z_}]:=PadLeft[Join[{Ceiling[(n/2)]+1},Table[1,{k,Floor[(n/2)]-1}]],z+Floor[(n/2)]-1]

Hook2[p_]:=Sort[Total[PadRight@MapIndexed[Hook2Aux,p]],Greater]

testHook2[n_]:=Transpose@{IntegerPartitions@n,Hook2/@IntegerPartitions@n}//Column

DurfeeSquare

DurfeeSquare[{}]:=0

DurfeeSquare[s_List]:=Module[{i,max=1},Do[If[s[[i]]≥i,max=i],{i,2,Min[Length[s],First[s]]}];max]

FrobeniusSymbol

FrobeniusSymbol@x_:=Module[
{d=DurfeeSquare@x},
{Take[x,d]-Range@d,Take[ConjugatePartition@x,d]-Range@d}
]

Unhook

Unhook[{}]={};

Unhook[p_]:=Prepend[Unhook[DeleteCases[Rest[p]-1,0]],p[[1]]+Length[p]-1]

testUnhook[n_]:=Transpose@{IntegerPartitions[n],Unhook/@IntegerPartitions[n]}//Column

Stems

Stems[{}]={};

Stems@p_:=Prepend[Stems[DeleteCases[Rest[p]-1,0]],{p[[1]],Length[p]-1}]

Stems/@ip@5//Column

ip@5

What is the inverse of Stems?

StemsInverse@{x_,0}:={x}

StemsInverse@{{x_,y_}}:=Prepend[Table[1,{y}],x]

StemsInverse@a_:=Prepend[StemsInverse[{1,-1}+#&/@Reverse/@Partition[Append[Rest@Flatten@a,0],2]],a[[1,1]]]

StemsInverse@{{13,4}}

a={{5,2},{13,4}}

a[[1,1]]

Append[Rest@Flatten@a,0]

Partition[Append[Rest@Flatten@a,0],2]

Reverse/@Partition[Append[Rest@Flatten@a,0],2]

a={1,-1}+#&/@Reverse/@Partition[Append[Rest@Flatten@a,0],2]

a={1,-1}+#&/@Reverse/@Partition[Append[Rest@Flatten@a,0],2]

StemsInverse@{{5,2},{13,4}}

Stems@{4,4,4}

StemsInverse@%

a={4,4,4}

a={1,-1}+#&/@Reverse/@Partition[Append[Rest@Flatten@a,0],2]

a={1,-1}+#&/@Reverse/@Partition[Append[Rest@Flatten@a,0],2]

a={1,-1}+#&/@Reverse/@Partition[Append[Rest@Flatten@a,0],2]

a={1,-1}+#&/@Reverse/@Partition[Append[Rest@Flatten@a,0],2]

a={1,-1}+#&/@Reverse/@Partition[Append[Rest@Flatten@a,0],2]

SelfConjugatePartitionQ, SelfConjugatePartitions, NotConjugatePartitions

SelfConjugatePartitionQ@x_:=x==ConjugatePartition@x

SelfConjugatePartitions@n_:=Select[IntegerPartitions@n,SelfConjugatePartitionQ]

NotSelfConjugatePartitions@n_:=Select[IntegerPartitions@n,Not@*SelfConjugatePartitionQ]

self-conjugate ⟺ odd distinct, scod[p]

scod@p_:=p/;p≠ConjugatePartition@p&&Not@(OddPartitionQ@p&&DistinctPartitionQ@p)

scod@p_:=Unhook@p/;p==ConjugatePartition@p

scod@p_:=Hook[p]/;OddPartitionQ@p&&DistinctPartitionQ@p

testscod@n_:=Module[{set},
set=Select[IntegerPartitions@n,Or[OddPartitionQ@#&&DistinctPartitionQ@#,
#==ConjugatePartition@#]&];
Transpose@{set,scod/@set}//Column
]

Fishhook

FishhookAux1[q_]:=Module[{c1},
c1=Table[(-1)^(n+1),{n,Length@q}].q;
{
Prepend[Table[1,c1-1],q[[1]]-c1+1],
Prepend[Table[1,q[[2]]-(q[[1]]-c1)],q[[1]]-c1]
}
]

FishhookAux2[x_,{a_,b_}]:=PadLeft[x,Length@x+a-1]

Fishhook[q0_]:=Module[{a,b,q,ps,h},
If[
Length@q0==2,
{a,b}=q0;
Which[
OddQ@a&&OddQ@b,{a-1,b+1},
EvenQ@a&&EvenQ@b,{a+1,b-1},
OddQ@a&&EvenQ@b,{a,b-1,1},
EvenQ@a&&OddQ@b,Prepend[Table[1,b-1],a+1]
],
q=If[OddQ@Length@q0,Append[q0,0],q0];
ps=FishhookAux1/@NestList[Drop[#,2]&,q,Floor[1/2Length@q0]];
h=Length@ps[[1,1]];
Total[
PadRight[#,Length@ps[[1,1]]]&/@Flatten[MapIndexed[FishhookAux2,ps,{2}],1]]
]
]

SplitEvens

SplitEvensAux@x_:=ConstantArray[x/2^#,2^#]&@IntegerExponent[x,2]

SplitEvens@p_:=ReverseSort@Flatten[SplitEvensAux/@p]

SplitEvens@{12,16,3,5,7}

Total@%

Total@{12,16,3,5,7}

Sylvester’s uv, Pak,  [1, p. 18]

odd partition ⟶ distinct partition

uv@{}={};

uv@p_:={Total@p}/;{1}==Union@p

uv[p_]:=Sort[Join[Unhook[(p+1)/2],Unhook[DeleteCases[(p-1)/2,0]]],Greater]/;And@@OddQ@p

testuv[n_]:=Transpose@{
Row/@Select[IntegerPartitions@n,OddPartitionQ],
Row/@uv/@Select[IntegerPartitions@n,OddPartitionQ]}//Column

SylvesterOD=uv;

testuv@6

Sylvester’s uv3

Glaisher’s theorem 
The number of partitions of a positive integer n into parts not divisible by d is the number of partitions with each part repeated less than d times.

IntegerQ/@({1,2,3,4}/3)

NoPartDivisibleBy3@p_:=Apply[And,Not@IntegerQ@#&/@(p/3)]

ip@8

NoPartDivisibleBy3/@ip@8

EachPartRepeatedLessThan3Times@p_:=Max[Last/@Tally@p]<3

EachPartRepeatedLessThan3Times/@ip@8

Split each partition p with no part divisible by 3 into two disjoint subpartitions, p1 and p2, according to the remainder mod 3.

mod31[n_]:=Select[IntegerPartitions[n],Mod[Length@#,3]==1&]

mod32[n_]:=Select[IntegerPartitions[n],Mod[Length@#,3]==2&]

mod31@8

mod32@8

Select[ip@8,NoPartDivisibleBy3]

Select[ip@8,EachPartRepeatedLessThan3Times]

Clear@split3

splitpart3@x_:={Floor[x/3]+Mod[x,3],Floor[x/3],Floor[x/3]}

splitpart3/@Range@12

split3@p_:=splitpart3/@p

split3/@Select[ip@8,NoPartDivisibleBy3]

Length@%

split3/@Select[ip@8,NoPartDivisibleBy3]//Column

For each partition with no part divisible by 3, apply Sylvester’s uv map to p1 and p2 and form the partition by collecting the resulting parts.

split3/@Select[ip@8,NoPartDivisibleBy3]

uv@{4,1,1,1,1}

vu, Sylvester’s Bijection V -> U, [2, p. 293]

vu

distinct partition ⟶ odd

vu[v_]:=Module[{r1,r2,r3,r4,r5,r6,r7,r8,r9},
{r1,r2}=Transpose@Partition[If[Mod[Length@v,2]==1,Append[v,0],v],2];
r3=Append[Most@r2-Rest@r1,Last@r2];
r6=r1-r2;
r4=Reverse@Accumulate@Reverse@ReplacePart[r3-1,Length@r1+Last@r3,-1];
r7=Reverse@Accumulate[Reverse@r6-1];
r8=Reverse@ConjugatePartition@r7;
r9=2r8-1;
r5=2r4-1;
Sort[Join[r9,r5],Greater]
]

SylvesterDO=vu;

sy

uv: O->D and vu: D->O, but O⋂D≠∅, so uv and vu cannot be extended to all partitions to form an involution. To get around this, define sy: P->P to be an involution by setting sy(p) = p if either p∉O⋃D, p∈O⋂D, uv(p)∈O⋂D, or vu(p)∈O⋂D.

sy[p_]:=p/;Not@OddPartitionQ@p&&Not@DistinctPartitionQ@p

sy[p_]:=p/;OddPartitionQ@p&&DistinctPartitionQ@p

sy@p_:=Module[{q},
q=uv@p;
If[OddPartitionQ@q&&DistinctPartitionQ@q,p,q]]/;OddPartitionQ@p

sy@p_:=Module[{q},
q=vu@p;
If[OddPartitionQ@q&&DistinctPartitionQ@q,p,q]]/;DistinctPartitionQ@p

Sometimes for p∈O,uv(p)∈O and uv(uv(p))∈O and even uv(uv(uv(p)))∈O.

uv@{3,1,1,1,1,1}

uv@{7,1}

uv@{5,3}

vu@{7,1}

ip@7

Row/@sy/@ip@7

Row/@CompletePartitions@7

temp@n_:=Complement[Row/@CompletePartitions@n,Row/@sy/@ip@n]

temp/@Range[30]

temp/@Range[31,40]

temp2@n_:=Length[Union[sy/@ip@n]]

temp2/@Range[30]

Wilf partitions and involution wi

wiAux@{a_,b_}:=Table[a,{n,b}]

FromTally@f_:=Sort[Flatten[wiAux/@f],Greater]

wi@p_:=p/;Not@DistinctPartitionQ[Last/@Tally@p]

wi@p_:=Sort[Flatten[wiAux/@Reverse/@Tally@p],Greater]/;DistinctPartitionQ[Last/@Tally@p]

Transpose@{IntegerPartitions@5,wi/@IntegerPartitions@5}//Column

wi@{3,3,1,1,1,1}

wi@{4,2,2,2}

perm, Permutation Representing an Involution

ip@5

tr/@ip@5

fr/@ip@5

tr@fr@#&/@ip@5

perm[f_][n_]:=Module[{ipn=IntegerPartitions@n},FindPermutation[ipn,f/@ipn]]

perm[tr@fr@#&]@5

perm[fr@tr@#&]@5

permorder

permorder[f_]@n_:=PermutationOrder@FindPermutation[ip@n,f/@ip@n]

PermutationOrder@perm[tr@fr@#&]@5

PermutationOrder@perm[Composition[tr,fr]]@5

PermutationOrder@perm[fr@tr@#&]@5

PermutationOrder@perm[Composition[tr,fr]]@12

PermutationOrder@perm[fr@tr@#&]@5

perm[tr]@5

perm[tr]@6

perm[fr]@5

PermutationReplace[perm[fr]@5,perm[tr]@5]

permorder[fr@tr@#&]@12

References

[1] Pak, The Nature of Partition Bijections II

[2] Sylvester, 
“A Constructive Theory of Partitions, Arranged in Three Acts, an Interact and an Exodion” is an article from American Journal of Mathematics, Volume 5.